├── README.md ├── README2.md ├── README3.md ├── arr.c ├── arrg.c ├── arrind.c ├── ialf3.h ├── icecream ├── inca.c ├── inca2.c ├── inca3.c ├── lib.inca ├── olmec ├── Design.md ├── Dresden43b.jpg ├── README.md ├── adverb.tab ├── adverb_private.h ├── adverbs.c ├── adverbs.h ├── all_tests.m4 ├── alpha.h ├── array.c ├── array.h ├── array_test.c ├── common.h ├── ed.c ├── editor.c ├── editor.h ├── encoding.c ├── encoding.h ├── exec.c ├── exec.h ├── exec_private.h ├── execs.tgz ├── io.c ├── io.h ├── io_test.c ├── lex.c ├── lex.h ├── lex_private.h ├── main.c ├── makefile ├── minunit.h ├── number.c ├── number.h ├── number_test.c ├── olmec_wizard.jpg ├── print.c ├── print.h ├── symtab.c ├── symtab.h ├── symtab_test.c ├── tables.m4 ├── tables.md ├── verb.tab ├── verb_private.h ├── verbs.c ├── verbs.h ├── xverb.c └── xverb.h ├── ppnarg.h ├── tea.sh └── teapot /README.md: -------------------------------------------------------------------------------- 1 | newest (incomplete) version is code-named 'olmec'. See olmec/README.md . 2 | 3 | inca 4 | ==== 5 | 6 | This document describes the interpreter implemented in inca.c, 7 | or inca "1". A revised and expanded version is implemented in inca2.c, 8 | and documented in README2.md and in 9 | [the wiki page](https://github.com/luser-dr00g/inca/wiki). 10 | 11 | A third rewrite has begun in inca3.c. Its documentation is (predictably) 12 | named README3.md. 13 | 14 | The newest (incomplete) version is code-named 'olmec'. See olmec/README.md . 15 | 16 | The final two commits of inca.c illustrate the problem inherent in 17 | the design. Add the new feature (user-function call without the ' or '' 18 | function-call functions) broke the existing code in tea.sh 19 | (the "use-case"). And so, the project was begun anew with a better design. 20 | 21 | It may surprise or amuse readers to learn that even the earliest inca.c was not my first brush with APL. Some years ago I read a great deal of the J wiki and then could not get it to compile and completely forgot. A few years later, having issued a programming challenge and received a few J answers, I looked again and wrote two postscript programs to simulate what I thought was going on. https://gist.github.com/luser-dr00g/9382217 and https://gist.github.com/luser-dr00g/9502855 22 | 23 | And some time later I stumbled upon some very old source code of mine which attempted (anticipated?) a similar arbitrary-dimensional system in C++. https://groups.google.com/d/topic/comp.lang.apl/3VNPOzcQMMI/discussion 24 | 25 | Summary: 26 | monadic functions: + id { size ~ iota < box # shape > unbox | abs ! not @ rev 27 | dyadic function: + add { from ~ find < assign # reshape , cat ; rowcat - minus . time 28 |    * pow % divide | mod & and ^ or = eq / compress \ expand 29 | mon ops: / reduce (.-|/\+><)@ transpose dy op: . matrix product 30 | variable ` (backtick) is set to result of the previous command. (was underscore) 31 | 32 | An online version is available courtesy of Thomas Baruchel. 33 | http://baruchel.hd.free.fr/apps/apl/inca/ 34 | which is awesome and even handles cut+paste. 35 | 36 | The program is based on and directly derived from the J-incunabulum, 37 | http://www.jsoftware.com/jwiki/Essays/Incunabulum 38 | and extended to allow propagating specifications "a+2+a<3", 39 | new functions minus,times,unbox. multi-digit integers. 40 | identity element for monadic use of minus,times,cat. 41 | Most extensions have been incorporated "ad-hoc", with 42 | an attempt to maintain consistency of style, balanced 43 | against a need (demand) for more commentary and more visible 44 | type identifiers. 45 | 46 | The name "inca" was chosen for its similarity to "incunabulum", 47 | as well as its obvious (to me) decomposition "In C, A", 48 | as well as the apparent similarity between array-structured data 49 | and the ancient Incan data-storage device, the quipu. 50 | http://en.wikipedia.org/wiki/Quipu 51 | 52 | The file inca.c compiles for me with cygwin32 gcc. 53 | The code does not consistently adhere to any particular 54 | version of the C standard, and may fail to compile with -pedantic, 55 | or any other options to enforce standards-conformance. 56 | 57 | I first found the J incunabulum through this SO question: 58 | http://stackoverflow.com/questions/13827096/how-can-i-compile-and-run-this-1989-written-c-program 59 | And I've added links to various explanatory pages as comments to that question, and a bugfix 60 | for the original. Here are the helpful links: 61 | http://www.jsoftware.com/papers/AIOJ/AIOJ.htm 62 | https://groups.google.com/d/msg/sayeret-lambda/Oxffk3aeUP4/QEuZocgVh5UJ 63 | http://archive.vector.org.uk/trad/v094/hui094_85.pdf 64 | 65 | Inca has been submitted for critique on comp.lang.c and and comp.lang.apl. 66 | And *some* of the advice given has been followed. It has not been tested 67 | with a 64-bit intptr_t. The code may make 32bit assumptions, although I've 68 | tried to be careful not to do this. I may not have been completely succesful. 69 | The basis of the interpreter is the ability to treat a pointer as an integer 70 | and pack them in the same-sized fields. Additionally, it assumes that pointer 71 | values may be distinguished from character values from their integer 72 | representations. This assumption is not guaranteed by the standard, but 73 | appears empirically to be true on my cygwin and ubuntu gnu linux testbeds. 74 | The original code also assumed that these pointer values will be positive, 75 | which is empirically *not* true on cygwin. Not sure about ubuntu, the code 76 | was fixed to use abs(intptr) before the range::type comparison well before 77 | it was ported. 78 | 79 | Inca will also accept command-line arguments into the program. These are 80 | available in the 'a' variable as a box-array of command-string arrays. 81 | Also included with the distribution is the small lib.inca file which 82 | accumulates a few functions that arose in postings to comp.lang.apl. 83 | If inca is invoked thusly: 84 | 85 | ./inca `cat lib.inca` 86 | 87 | Then the library can be executed by putting the box-array a in a box '<', 88 | making it executeable '$', and executing it ';'. 89 | 90 | ;$1){(<:1);<:('fy-1)+'fy-2 131 | 132 | Factorial function: 133 | 134 | f<:;(y>1){(<:1);<:y.fy-1 135 | 136 | In the run-length-encoded triangular matrix example, the rows were all the 137 | same length, so rowcat has an easy time to combine rows. But here, the two 138 | code sequences 139 | 140 | :1 141 | :('fy-1)+'fy-2 142 | 143 | are different lengths. So we box them, so rowcat doesn't screw things up. 144 | (FIXME: fix rowcat to pad unequal widths). 145 | 146 | <:1 147 | <:('fy-1)+'fy-2 148 | 149 | rowcat them together `((...);...)`, select one using a boolean expression `(y>1){`, and execute 150 | the resulting expression `;`. 151 | 152 | And also *not* executing a command-string prints the string, so: 153 | 154 | :Hello World! 155 | Hello World! 156 | 157 | 158 | Recalling the syntax for *executing* code from the command-line. 159 | 160 | ;$ 1 187 | { size 1 1 1 => 3 188 | ~ iota ~9 => 0 1 2 3 4 5 6 7 8 189 | < box <1 1 1 => <1 1 1 (bad example) 190 | # shape #~9 => 9 191 | > unbox ><1 1 1 => 1 1 1 192 | | absolute |-12 => 12 193 | ! not !0 1 0 => 1 0 1 194 | @ reverse @~9 => 8 7 6 5 4 3 2 1 0 195 | : yield array of remaining command string 196 | ; execute command string array 197 | $ convert array to command-string type 198 | 'w call function w with y as right arg 199 | function may be a variable containing code (with colon :), eg. square 200 | s<:y.y 201 | 's6 202 | 36 203 | or a parenthesized expression, without colon : 204 | '(y.y)6 205 | 36 206 | 207 | 208 | dyadic functions d AdW 209 | 210 | + plus 211 | { from 2 3{@~9 => 6 5 212 | ~ find 6 5~@~9 => 2 3 213 | < assign if a is a var (not really a function, but an interpreter action) 214 | # reshape 215 | , cat 216 | ; rowcat 217 | - minus (monadic: a=0) 218 | . times (monadic: a=1) 219 | * power (monadic: a=2) <-- this will be e with floating-point 220 | % divide (monadic: a=1) <-- this will make more sense with floating-point 221 | | modulus (reverse of C: w%a, divisor on the right) 222 | & and 223 | ^ or 224 | = equals? 225 | ! not-equal? 226 | : match 227 | < less-than (if a is not a var, see assign above) 228 | / compress 229 | \ expand 230 | "w call function w with x as left arg and y as right arg 231 | function may be a variable containing code (with colon :), eg x+1-y 232 | f<:x+1-y 233 | 3"f2 234 | 2 235 | or a parenthesized expression, without colon : 236 | 3"(x+1-y)2 237 | 2 238 | 239 | monadic operators 240 | 241 | / reduce f/W => w0 f (w1 f (w2 f ( ... wn-2 f wn-1))) 242 | \ scan f\W => (w0 f w1), ((w0 f w1) f w2), ... ) f wn-2) f wn-1) 243 | @ transpose .@ identity transpose 244 | -@ vertical transpose 245 | |@ horizontal transpose 246 | \@ y=x transpose 247 | /@ y=-x transpose 248 | +@ horz then vert 249 | >@ horz then y=x 250 | <@ horz then y=-x 251 | 252 | dyadic operator 253 | 254 | . matrix product Af.gW => f/Ag\@W 255 | ( @ for the left function designates "jot-dot", a null-scan over the matrix product ) 256 | eg. plus over times: +.. 257 | plus over plus: +.+ 258 | addition table: @.+ 259 | multiplication table: @.. 260 | 261 | over multidigit numbers and variables 262 | 
`
(backtick), and [a-z] 263 | 
`
(backtick) is set to the result of the previous line. (was underscore) 264 | 265 | The interpreter also implements a non-greedy "cat" for 266 | number vectors separated by spaces. Hence `1 2 3+~3` => `1 3 5` 267 | where `~` is the zero-based iota. Spaces must only be used between 268 | numbers. You may not pad operators with extra space or it will be 269 | misinterpreted. 270 | 271 | If the length of the command string exceeds 998 characters, 272 | the behavior is undefined. 273 | 274 | If array operands have incompatible sizes, the behavior 275 | is undefined. 276 | 277 | Example sessions: 278 | 279 | monadic functions. 280 | 281 | josh@Z1 ~/inca 282 | $ !. 283 | ./inca 284 | +5 285 | 286 | 5 287 | {1 2 3 288 | 1 289 | 3 290 | ~9 291 | 9 292 | 0 1 2 3 4 5 6 7 8 293 | ~0 294 | 0 295 | 296 | <12 297 | 298 | < 299 | 12 300 | #1 2 3;4 5 6 301 | 2 302 | 2 3 303 | |-25 304 | 305 | 25 306 | !4 307 | 308 | 0 309 | !0 310 | 311 | 1 312 | \@1 2 3;4 5 6;7 8 9;10 11 12 313 | 3 4 314 | 1 4 7 10 315 | 2 5 8 11 316 | 3 6 9 12 317 | \@4 3#1+~12 318 | 3 4 319 | 1 4 7 10 320 | 2 5 8 11 321 | 3 6 9 12 322 | @` 323 | 3 4 324 | 12 9 6 3 325 | 11 8 5 2 326 | 10 7 4 1 327 | 328 | josh@Z1 ~/inca 329 | $ 330 | 331 | Example session: dyadic functions and operators. 332 | (output has been augmented with a type-specifier then colon : then dims) 333 | 334 | $ ./inca 335 | 2 3+7 6 336 | 0:2 337 | 9 9 338 | 1{52 53 54 339 | 0: 340 | 53 341 | 5~4+~9 342 | 0: 343 | 1 344 | 4+~9 345 | 0:9 346 | 4 5 6 7 8 9 10 11 12 347 | a<10 348 | 0: 349 | 10 350 | b+a+b<6 351 | 0: 352 | 22 353 | b 354 | 0: 355 | 6 356 | ~64 357 | 0:64 358 | 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 359 | 8 8#` 360 | 0:8 8 361 | 0 1 2 3 4 5 6 7 362 | 8 9 10 11 12 13 14 15 363 | 16 17 18 19 20 21 22 23 364 | 24 25 26 27 28 29 30 31 365 | 32 33 34 35 36 37 38 39 366 | 40 41 42 43 44 45 46 47 367 | 48 49 50 51 52 53 54 55 368 | 56 57 58 59 60 61 62 63 369 | `,~9 370 | 0:73 371 | 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 0 1 2 3 4 5 6 7 8 372 | 12 6#` 373 | 0:12 6 374 | 0 1 2 3 4 5 375 | 6 7 8 9 10 11 376 | 12 13 14 15 16 17 377 | 18 19 20 21 22 23 378 | 24 25 26 27 28 29 379 | 30 31 32 33 34 35 380 | 36 37 38 39 40 41 381 | 42 43 44 45 46 47 382 | 48 49 50 51 52 53 383 | 54 55 56 57 58 59 384 | 60 61 62 63 0 1 385 | 2 3 4 5 6 7 386 | 5.-2 387 | 0: 388 | -10 389 | 2*3 390 | 0: 391 | 8 392 | 3*2 393 | 0: 394 | 9 395 | *3 396 | 0: 397 | 8 398 | **3 399 | 0: 400 | 256 401 | 2*2*3 402 | 0: 403 | 256 404 | +/~9 405 | 0: 406 | 36 407 | ./~9 408 | 0: 409 | 0 410 | ./1+~9 411 | 0: 412 | 362880 413 | ./1+~4 414 | 0: 415 | 24 416 | 1.2.3.4 417 | 0: 418 | 24 419 | 1 2 3 4+..5 6 7 8 420 | 0: 421 | 70 422 | 1.5 423 | 0: 424 | 5 425 | `+2.6 426 | 0: 427 | 17 428 | `+3.7 429 | 0: 430 | 38 431 | `+4.8 432 | 0: 433 | 70 434 | 435 | 436 | 437 | Example session: general transpose operator. 438 | 439 | $ ./inca 440 | 3 4#~12 441 | 0:3 4 442 | 0 1 2 3 443 | 4 5 6 7 444 | 8 9 10 11 445 | >@` 446 | 0:4 3 447 | 8 4 0 448 | 9 5 1 449 | 10 6 2 450 | 11 7 3 451 | \@` 452 | 0:3 4 453 | 8 9 10 11 454 | 4 5 6 7 455 | 0 1 2 3 456 | -@` 457 | 0:3 4 458 | 0 1 2 3 459 | 4 5 6 7 460 | 8 9 10 11 461 | <@` 462 | 0:4 3 463 | 3 7 11 464 | 2 6 10 465 | 1 5 9 466 | 0 4 8 467 | /@` 468 | 0:3 4 469 | 8 9 10 11 470 | 4 5 6 7 471 | 0 1 2 3 472 | -@` 473 | 0:3 4 474 | 0 1 2 3 475 | 4 5 6 7 476 | 8 9 10 11 477 | +@` 478 | 0:3 4 479 | 11 10 9 8 480 | 7 6 5 4 481 | 3 2 1 0 482 | |@` 483 | 0:3 4 484 | 8 9 10 11 485 | 4 5 6 7 486 | 0 1 2 3 487 | -@` 488 | 0:3 4 489 | 0 1 2 3 490 | 4 5 6 7 491 | 8 9 10 11 492 | .@` 493 | 0:3 4 494 | 0 1 2 3 495 | 4 5 6 7 496 | 8 9 10 11 497 | 498 | 499 | 500 | 501 | -------------------------------------------------------------------------------- /README3.md: -------------------------------------------------------------------------------- 1 | Inca3 2 | -- 3 | 4 | **Inca3** is the third re-write of the inca language interpreter (which is more or less 5 | defined by its implementation if/where the behavior disagrees with the documentation). 6 | 7 | Each rewrite has begun with the J incunabulum to which I then apply edits. 8 | Not only that, but I retype it from my handwritten notebook copy. This passes the 9 | code through my brain and fingers even though I'm merely "copying". 10 | 11 | Each additional feature or change is made compilable (and usually tested and apparently 12 | correct) before committing. Thus the commit log provides a time-wise view of the entire 13 | source. I also employ a select few "methodologies" which I try to apply consistently. 14 | These include DRY or Don't Repeat Yourself, which means that any two places in the source 15 | which "do the same thing" ought to be factored to maintain that condition. The practice 16 | of starting from a working, simple interpreter and extending is an application of the 17 | Tracer-Bullet strategy, where the first order of business is build a column connecting 18 | the top-down and bottom-up designs so the basic functionality can be directly tested and 19 | debugged, and each new feature can be added *laterally* and directly tested and debugged. 20 | 21 | The features: 22 | --- 23 | 24 | The symbol table interacts nicely with the parsing to analyze variable names at execution 25 | time. Many of the features of inca 1's *interpolation* abilities are now made available with 26 | a more natural behavior. A symbol is interpreted when passing from the left-stack to the 27 | right-stack by splitting off the longest defined prefix (which is pushed back onto the 28 | left-stack) and then repeating until the symbol is exhausted. Thus symbols can be directly 29 | adjacent to one-another with or without intervening whitespace. 30 | 31 | True APL characters. (Some are fake.) 32 | 33 | True APL shift-reduce parsing. 34 | 35 | Modern APL/J handling of verb rank as it applies to the frame/cell handling of its arguments. 36 | 37 | Multiprecision integers. 38 | 39 | 40 | Above this line is topical. 41 |
42 | Below this line is chronological. 43 | 44 | 45 | Beginning thoughts on a third rewrite. 46 | Oettinger's paper (http://www.mt-archive.info/Oettinger-1961.pdf) 47 | suggests unifying the representations of variables and 48 | functions by specifying their degree. Simple variables are degree 0. 49 | Degree >= 1 are functions accepting so many parameters. 50 | 51 | Iverson also describes unifying the behavior of functions with 52 | regard to the ranks of their actual parameters. 53 | (http://www.softwarepreservation.org/projects/apl/Books/ADICTIONARYOFAPL) 54 | Other ridiculously useful books and papers: 55 | [An Implementation of J](http://sblom.github.io/openj-core/ioj.htm), 56 | [IOJ presentation notes](http://archive.vector.org.uk/trad/v094/hui094_85.pdf) 57 | [Rationalized APL](http://www.jsoftware.com/papers/RationalizedAPL.htm), 58 | [A Dictionary of APL](http://www.softwarepreservation.org/projects/apl/Books/ADICTIONARYOFAPL) 59 | [Practical Uses of a Model of APL](http://www.jsoftware.com/papers/APLModel.htm) 60 | [Kona wiki](https://github.com/kevinlawler/kona/wiki) 61 | 62 | I also want to better coordinate the behavior of the data types. 63 | So I think I need a {quad} symbol for system variables. 64 | Perhaps it can even handle variable index-origin sensibly. 65 | But for datatypes, I'm imagining a selectable scheme for overflow promotions. 66 | The behavior of inca "1" is: 67 | 68 | integer overflow -> OVERFLOW (invokes "undefined behavior" in the C implementation) 69 | 70 | The behavior of inca2 is: 71 | 72 | integer overflow -> promote to double 73 | 74 | For the next one, I want to offer several options and several new floating-point types. 75 | 76 | double 77 | quad-double 78 | (complex) <-- maybe not right away, but I want an extensible framework that can 79 | accomodate this later. 80 | rational 81 | multiprecision integers 82 | rational/multiprecision 83 | 84 | And the system variable will select which type integer overflow will promote to. 85 | 86 | As for variables, I'm trying to imagine a way to allow for multicharacter variable 87 | names while still allowing unbroken expressions involving single-letter variables. 88 | I want `a<1` `b<+` `c<2` `abc` to still yield 3, unless there's an "abc" variable defined. 89 | Currently, the symbol table is dead simple. An array of 52 pointers (2 * 26 letters 90 | in the alphabet). But what if it were overlayed with another data structure, like 91 | a trie or search-tree? In inca 1 and 2, all objects are simultaneously considered part 92 | of the symbol table (or not, as the case may be; if it's a temporary or something) 93 | and part of the allocation stack (for garbage-collection). Adding another member to 94 | the archetype struct will allow objects to be organized along yet another parallel 95 | structuring principle. 96 | 97 | From the "abc" example, with N-way splits at each level. 98 | 99 | [a] = { 1 } 100 | [a] 101 | [b] = { } 102 | [a] 103 | [b] 104 | [c] = { 5 } 105 | [c] 106 | [d] 107 | [b] = { + } 108 | [c] = { 2 } 109 | [d] = { } 110 | [e] = { } 111 | 112 | So, descending the tree has precedence over broad pattern matching. Having parsed 113 | a as the node 114 | 115 | { 1 } 116 | [a] 117 | [b] = { } 118 | [a] 119 | [b] 120 | [c] = { 5 } 121 | [c] 122 | 123 | if the next char is 'b', it descends the tree to 124 | 125 | [b] = { } 126 | [a] 127 | [b] 128 | [c] = { 5 } 129 | 130 | even though 'ab' itself is not defined. 131 | 132 | This may be a twisty and confusing set of rules, but I think it will afford the 133 | maximum flexibility of usage. User functions can still be single characters which 134 | behave more-or-less syntactically like basic functions. But idioms of these functions 135 | can also be overrided. 136 | 137 | 138 | 139 | As a new side-angle/distraction, I've discovered how to access the graphics characters in xterm. 140 | So the new version will also include an extended alphabet and a more powerful line-editor. 141 | 142 | The basics of the extended character set is implemented. Switch to the alternate characters with ctrl-N `^N` and back to normal with ctrl-O `^O`. There is one function available fromthe extended set: plusminus. Monadic plusminus performs a negation of the argument. Dyadic plus minus creates an array and returns both the sum and difference of the left and right arguments. 143 | 144 | There is a third set of characters available that I may incorporate into inca's alternate set. But I intend inca to maintain only 2 input modes. So the third set will only be a bank to draw from, not the basis of its own defined set. This process has begun and the alternate keyboard no longer has the silly `LF` `CR` `VT` etc chars, but these may be useful in displaying strings. 145 | 146 | The extensible symbol table is implemented. Very much as described above, it has 52-way branching at each node. The searching function has a defining mode where it allocates new nodes for each char in the symbol, and a separate prefix search mode where it returns the longest match. 147 | 148 | I'm currently studying the J documents concerning the parsing. Hopefully I can replace the procedural parsing with a table-driven setup. 149 | 150 | -- 151 | 152 | 3/11/2015 153 | 154 | To sum up so far, beginning (yet again) with the incunabulum 155 | I've added a custom 156 | line-editor using vt220 commands compatible with xterm, setting the 157 | mode using the terminal-indepedent (and POSIX-portable) termios library. 158 | Since it works on with Cygwin's xorg server on Windows 8, I feel safe 159 | in assuming that this will be fairly-easily portable among modern 160 | unix/linux systems. 161 | 162 | The editor itself is guided by [The Craft of Text Editing](http://www.finseth.com/craft/craft.pdf) (4.98MB pdf). 163 | 164 | Again with vt220 codes, I've added an *alternate keyboard* full of 165 | crazy shapes and doodles collected from the vt220 line-drawing set 166 | and "uk" set. These have yet to be sensibly organized, but I have 167 | added one non-ascii doodle command from the alternate keyboard as 168 | a *tracer-bullet* implementation strategy. This is the plus/minus 169 | function which performs negation monadically, and dyadically it 170 | returns an array of the sum and difference of the left and right 171 | arguments (a sensible interpretation of plus/minus, I think). 172 | 173 | Next, I've added a trie structure for an extensible symbol table. 174 | For lookups, it uses a prefix search: returning the longest defined 175 | prefix of the requested key. This should permit the simultaneous 176 | use of of long names and space-free short names in a tight expression. 177 | Thus, this is no longer just a golfing language. 178 | 179 | Next, I've reimplemented the `wd()` function which scans the 180 | expression to form words. It now uses a table-driven approach 181 | similar to the description in *An Implementation of J* (I do not 182 | understand the diagram of the table there). To cooperate with 183 | the symbol-lookup mechanism, it consumes any run of alphabetic 184 | characters and collects it as a single symbol-typed object 185 | which contains a zero-terminated "C" string. This is distinct 186 | from the char-typed objects which are "pascal-style" with a 187 | separate count and no terminator. Or rather "will be", as the 188 | char-typed objects aren't really implemented yet. 189 | 190 | Next up, I'm going to take a hard look at the `ex()` function 191 | and the stack-based algorithms described in *An Implementation of J* 192 | and *A Dictionary of APL*. So that one will be reimplemented to be 193 | table-based as well and probably to use true right-to-left semantics now. 194 | 195 | -- 196 | 197 | Table-driven parser is written and working, including an extra 198 | *implicit-parens* feature. The assignment character has been changed to 199 | left-guillemot, accessed from the alternate keyboard `^n` `<` `^o`. 200 | 201 | -- 202 | 203 | The alt keyboard is now accessible with the ALT key. Ctrl-N is now an 204 | "ALT-lock" toggle key. 205 | 206 | The code has been reworked to be very table-driven using X-Macros to 207 | construct symbolically-indexed tables. 208 | 209 | The alt keyboard is being reworked to produce true Unicode APL characters 210 | (which xterm handles just fine). 211 | 212 | -- 213 | 214 | Implemented scalar agreement (scalar extension) for the plus() function. 215 | Minus, times, and divide do not yet do this. 216 | 217 | Shifting thoughts toward the implementation of multiple numeric types. 218 | 219 | -- 220 | 221 | I had a great idea for numeric types. The thing I most want to avoid is 222 | different sizes of atoms in the array data. Because then all access to 223 | the data has to be cast to the appropriate pointer type, and we need to 224 | switch on the type even just to iterate through it. 225 | 226 | So everything needs to be the same size. Drawing from the Lisp book I just 227 | finished reading, this is the exact same problem that early Lisp 228 | implementations faced when dealing with numeric types. So we can borrow 229 | some of the same solutions. I don't want to add a type word to every atom. 230 | I like having the basis as `int`, passing the issue off to the C implementation 231 | to determine what `int` is most appropriate for a given machine. 232 | 233 | So the idea is to steal bits off the top of the `int` to use as a type 234 | indicator. So we'll lose some precision for atomic integers. But full-width 235 | integers will also be accessible in a separate table. Floating-point numbers 236 | will also be stored in a separate table. 237 | 238 | I haven't decided exactly how many bits to use, so I hope to make the 239 | code adaptable to different choices of partition. But for the first draft, 240 | the `int` will divide right down the middle. So atomic integers will 241 | be in the range -32768..32767 . 242 | 243 | 0x00112233 244 | 0000nnnn small atomic integer nnnn 245 | bbbbiiii indirect number at table[bbbb][iiii] 246 | stored as (bank+1,index) 247 | 248 | There will be a master table of pointers to tables for each type. These 249 | should be `struct` so each level can maintain its own bookkeeping fields. 250 | 251 | -- 252 | 253 | Instead of structs, the master table is an abstract BOX array. For 254 | bookkeeping, element[0] is treated as a top-of-list counter/cursor, 255 | and the remaining elements treated as a 1-index-origin array. 256 | 257 | The fixnum and flonum tables also use element[0] as a counter 258 | and the remaining elements are the data. 259 | 260 | Presumably, to extend this to rationals, element[0] of ratnum will 261 | be count/1. :) 262 | 263 | 264 | -- 265 | 266 | Some big updates. The Rank conjunction and generalized rank:frame/cell behavior 267 | for verbs, all wrapped in macros for easy inclusion in verb functions. 268 | 269 | Overflow detection for integer arithmetic. Currently this triggers a promotion 270 | to floating-point (double) which is the only larger type. But I'm carefully 271 | considering how to add an arbitrary precision integer. And then it will need 272 | a configuration option, perhaps accessed by a conjunction like rank. 273 | 274 | Only a very few functions are implemented so far. And only the math functions 275 | use the rank behavior. So plus, minus, times, divide. Iota and rho are partially 276 | implemented. And the reduce adverb. And the conjunctions rank and curry/compose. 277 | 278 | This iteration of the code is more "depth"-first than earlier gos. 279 | 280 | Assignment is now the left-arrow (ALT-[). 281 | 282 | -- 283 | 284 | 285 | Addeed Multiprecision integers. Addition, subtraction, and multiplication are 286 | working. I'm stilling working on division. 287 | 288 | The issue of what to do with arithmetic when one argument is a Multiprecision 289 | integer and the other is a floating-point number is posed on Programmers.SE: 290 | http://programmers.stackexchange.com/questions/280335/what-do-you-get-when-you-cross-a-multi-precision-integer-with-a-floating-point-n 291 | 292 | 293 | -- 294 | 295 | I'm thinking about creating a new type for a new kind of indirect array. 296 | Some of the ideas were described in this post: 297 | https://groups.google.com/d/topic/comp.lang.apl/0_Y4bwankxY/discussion . 298 | And an unrelated discussion from comp.lang.c will catch any one up on the 299 | background of the array structure and the C implementation. 300 | https://groups.google.com/d/topic/comp.lang.c/Dvbze4_foZY/discussion 301 | 302 | This new type will be called DOPE. And the array data contains a vector 303 | the same length as the dimensions. This is the dope-vector which contains 304 | the multipliers for each index. For a simple indirect array, a shared-data 305 | array, the dope-vector will contain the cached results of weighting vector 306 | which is calculated as part of applying normal index tuples. 307 | 308 | A transpose operation can simply reorder these weights to match the new 309 | index ordering (as well as reordering the dims). 310 | 311 | Another new piece that is needed is a mixed-radix increment function to 312 | facilitate iterating through higher-dimensional arrays while still having 313 | the indices for computation (and for DOPE arrays, for accessing the data). 314 | That is, DOPE arrays do not have a ravelled representation. They have a 315 | "linear" representation in a broader algebraic sense than the usual 316 | hard-linked contiguous arrays. 317 | 318 | -------------------------------------------------------------------------------- /arr.c: -------------------------------------------------------------------------------- 1 | /* 2 | Example code for SO answer: 3 | http://stackoverflow.com/questions/30023867/how-can-i-work-with-dynamically-allocated-arbitrary-dimensional-arrays/30023868#30023868 4 | */ 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | typedef struct arr { 12 | int r; 13 | int d[1]; 14 | } *arr; 15 | 16 | int productdims(int rank, int *dims){ 17 | int z=1; 18 | for(int i=0; ir = rank; 27 | memmove(z->d,dims,rank*sizeof(int)); 28 | return z; 29 | } 30 | 31 | /* 32 | idx = i0*w0 + i1*w1 + ... iN*wN 33 | w0 = d1*d2*d3* ... *dN 34 | w1 = d2*d3* ... *dN 35 | ... 36 | wN = 1 37 | 38 | idx=0 39 | idx+=i0 40 | 41 | idx*=d1 42 | idx+=i1 43 | 44 | idx*=d2 45 | idx+=i2 46 | ... 47 | idx*=dN 48 | idx+=iN 49 | idx*=1 50 | 51 | */ 52 | 53 | int *elem(arr a, ...){ 54 | va_list ap; 55 | int idx = 0; 56 | 57 | va_start(ap,a); 58 | if (a->r){ 59 | idx = va_arg(ap,int); 60 | for(int i=1; ir; i++){ 61 | idx *= a->d[i]; 62 | idx += va_arg(ap,int); 63 | } 64 | } 65 | va_end(ap); 66 | 67 | return &a->d[a->r + idx]; 68 | } 69 | 70 | #if 0 71 | int *elem(arr a, ...){ 72 | va_list ap; 73 | int idx = 0; 74 | int weight = 1; 75 | int *ind=calloc(a->r, sizeof(int)); 76 | 77 | va_start(ap,a); 78 | for(int i=0; i < a->r; i++){ 79 | ind[i]=va_arg(ap,int); 80 | } 81 | va_end(ap); 82 | 83 | for(int i=a->r-1; i>=0; i--){ 84 | idx += ind[i]*weight; 85 | weight *= a->d[i]; 86 | } 87 | 88 | return &a->d[a->r + idx]; 89 | } 90 | #endif 91 | 92 | 93 | int main() { 94 | 95 | 96 | { 97 | int i,n=6; 98 | arr m = makearr(1, (int[]){n}); 99 | for (i=0;i 2 | #include 3 | #include 4 | #include 5 | #include"ppnarg.h" //https://github.com/luser-dr00g/inca/blob/master/ppnarg.h 6 | typedef char C; typedef int I; 7 | typedef struct a{I r,*d,*w,*p;}*A; 8 | #define R return 9 | #define DO(n,x){I i=0,N=(n);for(;ir=r; z->d=(I*)(z+1); z->w=z->d+r; z->p=NULL; 14 | memcpy(z->d,d,r*sizeof(I)); dw(r,d,z->w); R z; } 15 | A ara(I r,I*d){ I sz=tr(r,d); A z=ah(r,d,sz); z->p=z->w+r; R z; } /* arraya */ 16 | dv(I r,I*d,va_list v){ DO(r,d[i]=va_arg(v,I)) } /* loaddimsv */ 17 | A ar(I r,...){ va_list v; I d[r]; va_start(v,r); dv(r,d,v); va_end(v); R ara(r,d); } /* array rm */ 18 | #define ar(...)ar(PP_NARG(__VA_ARGS__),__VA_ARGS__) 19 | A caa(I*p,I r,I*d){ A z=ah(r,d,0); z->p=p; R z; } /* casta rm */ 20 | A ca(I*p,I r,...){ va_list v; I d[r]; va_start(v,r); dv(r,d,v); va_end(v); R caa((I*)p,r,d); } 21 | #define ca(p,...)ca((I*)p,PP_NARG(__VA_ARGS__),__VA_ARGS__) 22 | A cl(A a){ A z=ah(a->r,a->d,0); 23 | memcpy(z->d,a->d,z->r*sizeof(I)); 24 | memcpy(z->w,a->w,z->r*sizeof(I)); z->p=a->p; R z; } /* clone */ 25 | I*ela(A a,I*j){ I x=0; DO(a->r, x+=j[i]*a->w[i]) R a->p+x; } /* elema */ 26 | I*elv(A a,va_list v){ I j[a->r]; dv(a->r,j,v); R ela(a,j); } /* elemv */ 27 | I*el(A a,...){ I*z; va_list v; va_start(v,a); z=elv(a,v); va_end(v); R z; } /* elem */ 28 | int *vx(I x,I*d,I r,I*v){ DO(r, v[r-1-i]=x%d[r-1-i]; x/=d[r-1-i]) R v; } /* vector_index */ 29 | int rx(I*v,I*d,I r){ I z=*v; DO(r-1, z*=d[i+1]; z+=v[i+1]) R z; } /* ravel_index */ 30 | A cp(A a){ I sz=tr(a->r,a->d); A z=ah(a->r,a->d,sz); z->p=z->w+z->r; 31 | I j[z->r]; DO(sz, vx(i,z->d,z->r,j); z->p[i]=*ela(a,j)) R z; } /* copy rm */ 32 | #define CASE ;break;case 33 | 34 | #define OP(x,y)((((x))*256)+((y))) 35 | #define OPS(_) _("+", '+', 0, +, 0) \ 36 | _("*", '*', 0, *, 1) \ 37 | _("=", '=', 0, ==, 1) \ 38 | _("==",'=','=',==, 1) \ 39 | /* f f0 f1 F id */ 40 | #define BINOP(f,f0,f1,F,id) CASE OP(f0,f1): *el(z,i) = *el(x,i) F *el(y,i); 41 | A bin(A x,C*f,A y){ A z=cp(x); DO(x->d[0], switch(OP(*f,f[1])){ OPS(BINOP) }) R z; } 42 | #define bin(X,F,Y) bin(X,#F,Y) 43 | #define REDID(f,f0,f1,F,id) CASE OP(f0,f1): z = id; 44 | #define REDOP(f,f0,f1,F,id) CASE OP(f0,f1): z = *el(y,n-2-i) F z; 45 | int red(C*f,A y){ I z; I n=y->d[0]; 46 | switch(OP(*f,f[1])){ OPS(REDID) } 47 | if (n){ z=*el(y,n-1); 48 | if (n-1>0) DO(n-1, switch(OP(*f,f[1])){ OPS(REDOP) }) } 49 | R z; } 50 | #define red(F,Y) red(#F,Y) 51 | 52 | A xt(A a,I x){ I r=a->r+x; I d[r]; 53 | DO(x, d[i]=1) memcpy(d+x,a->d,a->r*sizeof(I)); R caa(a->p,r,d); } /* extend */ 54 | A iot(I n){ A z=ar(n); DO(n,*el(z,i)=i) R z; } /* index generator */ 55 | 56 | A xp(A a,I*j){ 57 | I d[a->r]; I w[a->r]; 58 | DO(a->r, d[i]=a->d[j[i]]; 59 | w[i]=a->w[j[i]]) 60 | A z=caa(a->p,a->r,d); 61 | memcpy(z->w,w,a->r*sizeof(I)); R z; } /* transpose */ 62 | 63 | A sl0(A a,I x){ I r=a->r-1; A z=ah(r,a->d+1,0); 64 | memcpy(z->w,a->w+1,r*sizeof(I)); 65 | z->p=a->p+x*a->w[0]; R z; } 66 | 67 | A sl(A a,I*s,I*f){ I r=0; 68 | DO(a->r, r+=s[i]!=f[i]) 69 | I d[r]; I w[r]; I j=0; 70 | DO(r, while(s[j]==f[j])++j; 71 | d[i]=1+(s[j]w[j] : -a->w[j]; 73 | ++j) 74 | A z=caa(a->p,r,d); 75 | memcpy(z->w,w,r*sizeof(I)); DO(a->r, z->p += s[i] * a->w[i]) R z; } /* slices [s[i]..f[i]] */ 76 | 77 | I contig(A a){ I x=1; 78 | DO(a->r, if(a->w[a->r-1-i]!=x) R 0; 79 | x*=a->d[a->r-1-i]) 80 | R 1; } 81 | 82 | pr(A a,I wid){ I max; I copy=0; 83 | if (wid){ max=wid; } else { 84 | I sz=tr(a->r,a->d); 85 | if (!contig(a)){ 86 | a=cp(a); 87 | copy=1; 88 | } 89 | max=0; 90 | DO(sz, 91 | sz=snprintf(NULL,0,"%d",a->p[i]); 92 | if (sz>max) max=sz) 93 | } 94 | switch(a->r){ 95 | case 0: printf("%*d\n", max, *a->p); break; 96 | case 1: { 97 | I sep=0; 98 | DO(a->d[0], 99 | if (sep) printf(" "); 100 | printf("%*d", max, *el(a,i)); 101 | sep=1) } 102 | if (wid==0) printf("\n"); break; 103 | default:DO(a->d[0], A t=sl0(a,i); 104 | pr(t,max); 105 | printf("\n"); 106 | free(t)) break; 107 | } 108 | if(copy)free(a); } 109 | 110 | dmp(A a){ 111 | printf("%d\n",a->r); 112 | DO(a->r,printf("%d ",a->d[i])) printf("\n"); 113 | DO(a->r,printf("%d ",a->w[i])) printf("\n"); 114 | printf("%p %p %p %p\n", 115 | (void*)a, (void*)a->d, (void*)a->w, (void*)a->p); } 116 | 117 | int main(){ 118 | A x=ar(3); 119 | *el(x,0)=5; 120 | *el(x,1)=6; 121 | *el(x,2)=7; 122 | dmp(x); 123 | pr(x,0); 124 | 125 | A a=iot(24); 126 | dmp(a); 127 | pr(a,0); 128 | A b=ca(a->p,2,3,4); 129 | dmp(b); 130 | pr(b,0); 131 | A c=sl(b,(I[]){0,1,1},(I[]){0,2,3}); 132 | pr(c,0); 133 | A d=xp(c,(I[]){1,0}); 134 | pr(d,0); 135 | return 0; 136 | } 137 | -------------------------------------------------------------------------------- /ialf3.h: -------------------------------------------------------------------------------- 1 | 2 | 3 | /* 4 | The Alphabet table defines the input and output of character data 5 | (including non-ascii APL symbols). 6 | */ 7 | /* ALPHA_##NAME base ext input output (ext corresponds to 'mode' in getln)*/ 8 | #define ALPHATAB(_) \ 9 | _( SPACE, ' ', 0, " ", " " ) \ 10 | _( a, 'a', 0, "a", "a" ) /* basic latin alphabet */ \ 11 | _( b, 'b', 0, "b", "b" ) \ 12 | _( c, 'c', 0, "c", "c" ) \ 13 | _( d, 'd', 0, "d", "d" ) \ 14 | _( e, 'e', 0, "e", "e" ) \ 15 | _( f, 'f', 0, "f", "f" ) \ 16 | _( g, 'g', 0, "g", "g" ) \ 17 | _( h, 'h', 0, "h", "h" ) \ 18 | _( i, 'i', 0, "i", "i" ) \ 19 | _( j, 'j', 0, "j", "j" ) \ 20 | _( k, 'k', 0, "k", "k" ) \ 21 | _( l, 'l', 0, "l", "l" ) \ 22 | _( m, 'm', 0, "m", "m" ) \ 23 | _( n, 'n', 0, "n", "n" ) \ 24 | _( o, 'o', 0, "o", "o" ) \ 25 | _( p, 'p', 0, "p", "p" ) \ 26 | _( q, 'q', 0, "q", "q" ) \ 27 | _( r, 'r', 0, "r", "r" ) \ 28 | _( s, 's', 0, "s", "s" ) \ 29 | _( t, 't', 0, "t", "t" ) \ 30 | _( u, 'u', 0, "u", "u" ) \ 31 | _( v, 'v', 0, "v", "v" ) \ 32 | _( w, 'w', 0, "w", "w" ) \ 33 | _( x, 'x', 0, "x", "x" ) \ 34 | _( y, 'y', 0, "y", "y" ) \ 35 | _( z, 'z', 0, "z", "z" ) \ 36 | _( A, 'A', 0, "A", "A" ) \ 37 | _( B, 'B', 0, "B", "B" ) \ 38 | _( C, 'C', 0, "C", "C" ) \ 39 | _( D, 'D', 0, "D", "D" ) \ 40 | _( E, 'E', 0, "E", "E" ) \ 41 | _( F, 'F', 0, "F", "F" ) \ 42 | _( G, 'G', 0, "G", "G" ) \ 43 | _( H, 'H', 0, "H", "H" ) \ 44 | _( I, 'I', 0, "I", "I" ) \ 45 | _( J, 'J', 0, "J", "J" ) \ 46 | _( K, 'K', 0, "K", "K" ) \ 47 | _( L, 'L', 0, "L", "L" ) \ 48 | _( M, 'M', 0, "M", "M" ) \ 49 | _( N, 'N', 0, "N", "N" ) \ 50 | _( O, 'O', 0, "O", "O" ) \ 51 | _( P, 'P', 0, "P", "P" ) \ 52 | _( Q, 'Q', 0, "Q", "Q" ) \ 53 | _( R, 'R', 0, "R", "R" ) \ 54 | _( S, 'S', 0, "S", "S" ) \ 55 | _( T, 'T', 0, "T", "T" ) \ 56 | _( U, 'U', 0, "U", "U" ) \ 57 | _( V, 'V', 0, "V", "V" ) \ 58 | _( W, 'W', 0, "W", "W" ) \ 59 | _( X, 'X', 0, "X", "X" ) \ 60 | _( Y, 'Y', 0, "Y", "Y" ) \ 61 | _( Z, 'Z', 0, "Z", "Z" ) \ 62 | /* ALPHA_NAME base ext input output */ \ 63 | _( ONE, '1', 0, "1", "1" ) /* ascii digits */ \ 64 | _( TWO, '2', 0, "2", "2" ) \ 65 | _( THREE, '3', 0, "3", "3" ) \ 66 | _( FOUR, '4', 0, "4", "4" ) \ 67 | _( FIVE, '5', 0, "5", "5" ) \ 68 | _( SIX, '6', 0, "6", "6" ) \ 69 | _( SEVEN, '7', 0, "7", "7" ) \ 70 | _( EIGHT, '8', 0, "8", "8" ) \ 71 | _( NINE, '9', 0, "9", "9" ) \ 72 | _( ZERO, '0', 0, "0", "0" ) \ 73 | _( ONE1, '1', 1, "1", "1" ) /* accept same digits in alt mode */ \ 74 | _( TWO1, '2', 1, "2", "2" ) \ 75 | _( THREE1, '3', 1, "3", "3" ) \ 76 | _( FOUR1, '4', 1, "4", "4" ) \ 77 | _( FIVE1, '5', 1, "5", "5" ) \ 78 | _( SIX1, '6', 1, "6", "6" ) \ 79 | _( SEVEN1, '7', 1, "7", "7" ) \ 80 | _( EIGHT1, '8', 1, "8", "8" ) \ 81 | _( NINE1, '9', 1, "9", "9" ) \ 82 | _( ZERO1, '0', 1, "0", "0" ) \ 83 | _( PLUS, '+', 0, "+", "+" ) /* ascii punctuation */ \ 84 | _( MINUS, '-', 0, "-", "-" ) \ 85 | _( EQUAL, '=', 0, "=", "=" ) \ 86 | _( UNDERSCORE, '_', 0, "_", "_" ) \ 87 | _( LBRACE, '{', 0, "{", "{" ) \ 88 | _( RBRACE, '}', 0, "}", "}" ) \ 89 | _( PIPE, '|', 0, "|", "|" ) \ 90 | _( LBRACKET, '[', 0, "[", "[" ) \ 91 | _( RBRACKET, ']', 0, "]", "]" ) \ 92 | _( BACKSLASH, '\\', 0, "\\", "\\" ) \ 93 | _( COLON, ':', 0, ":", ":" ) \ 94 | _( SEMICOLON, ';', 0, ";", ";" ) \ 95 | _( QUOTE, '\'', 0, "'", "'" ) \ 96 | _( DBLQUOTE, '"', 0, "\"", "\"" ) \ 97 | _( COMMA, ',', 0, ",", "," ) \ 98 | _( PERIOD, '.', 0, ".", "." ) \ 99 | _( SLASH, '/', 0, "/", "/" ) \ 100 | _( LANG, '<', 0, "<", "<" ) \ 101 | _( RANG, '>', 0, ">", ">" ) \ 102 | _( QUESTION, '?', 0, "?", "?" ) \ 103 | _( TILDE, '~', 0, "~", "~" ) \ 104 | _( BACKQUOTE, '`', 0, "`", "`" ) \ 105 | _( EXCL, '!', 0, "!", "!" ) \ 106 | _( AT, '@', 0, "@", "@" ) \ 107 | _( HASH, '#', 0, "#", "#" ) \ 108 | _( DOLLAR, '$', 0, "$", "$" ) \ 109 | _( PERCENT, '%', 0, "%", "%" ) \ 110 | _( CARET, '^', 0, "^", "^" ) \ 111 | _( AMPERSAND, '&', 0, "&", "&" ) \ 112 | _( STAR, '*', 0, "*", "*" ) \ 113 | _( LPAREN, '(', 0, "(", "(" ) \ 114 | _( RPAREN, ')', 0, ")", ")" ) \ 115 | /* ALPHA_NAME base ext input output */ \ 116 | _( PLUSMINUS, MODE1('g'), 1, "g", ESC(n)"g""\xE" ) /* xterm alt graphics chars */ \ 117 | _( TWODOTS, MODE1('!'), 1, "!", ESC(o)"(""\xE" ) \ 118 | _( DIAERESIS, MODE1('!'), 1, "!", /*U+00a8*/ /*"\xc2"*/"\xa8" ) \ 119 | _( HIMINUS, MODE1('@'), 1, "@", ESC(o)"/""\xE" ) \ 120 | _( MACRON, MODE1('@'), 1, "@", /*U+00af*/ /*"\xc2"*/"\xaf" ) \ 121 | _( NOTEQUAL, MODE1('|'), 1, "|", ESC(n)"|""\xE" ) \ 122 | _( LESS, '<', 1, "#", "<" ) \ 123 | _( LESSEQ, MODE1('$'), 1, "$", /*U+2264*/ "\xe2\x89\xa4") \ 124 | _( LESSEQUAL, MODE1('$'), 1, "$", ESC(n)"y""\xE" ) \ 125 | _( EQALT, '=', 1, "%", "=" ) \ 126 | _( MOREEQ, MODE1('^'), 1, "^", /*U+2265*/ "\xe2\x89\xa5") \ 127 | _( MOREEQUAL, MODE1('^'), 1, "^", ESC(n)"z""\xE" ) \ 128 | _( MORE, '>', 1, "&", ">" ) \ 129 | _( EQSLASH, MODE1('*'), 1, "*", ESC(n)"|""\xE" ) \ 130 | _( QUEST, '?', 1, "q", "?" ) \ 131 | _( OMEGA, MODE1('w'), 1, "w", /*U+2375*/ "\xe2\x8d\xb5" ) \ 132 | _( EPSILON, MODE1('e'), 1, "e", /*U+2208*/ "\xe2\x88\x88" ) \ 133 | _( RHO, MODE1('r'), 1, "r", /*U+2374*/ "\xe2\x8d\xb4" ) \ 134 | _( TILDEOP, MODE1('t'), 1, "t", /*U+223c*/ "\xe2\x88\xbe" ) \ 135 | _( UPARROW, MODE1('y'), 1, "y", /*U+2191*/ "\xe2\x86\x91" ) \ 136 | _( DNARROW, MODE1('u'), 1, "u", /*U+2193*/ "\xe2\x86\x93" ) \ 137 | _( IOTA, MODE1('i'), 1, "i", /*U+2373*/ "\xe2\x8d\xb3" ) \ 138 | _( CIRCLE, MODE1('o'), 1, "o", /*U+25cb*/ "\xe2\x97\x8b" ) \ 139 | _( STAROP, MODE1('p'), 1, "p", /*U+22c6*/ "\xe2\x8b\x86" ) \ 140 | _( LTARROW, MODE1('['), 1, "[", /*U+2190*/ "\xe2\x86\x90" ) \ 141 | _( RTARROW, MODE1('{'), 1, "{", /*U+2192*/ "\xe2\x86\x92" ) \ 142 | _( ALPHA, MODE1('a'), 1, "a", /*U+237a*/ "\xe2\x8d\xba" ) \ 143 | _( LEFTCEIL, MODE1('s'), 1, "s", /*U+2308*/ "\xe2\x8c\x88" ) \ 144 | _( LEFTFLOOR, MODE1('d'), 1, "d", /*U+230a*/ "\xe2\x8c\x8a" ) \ 145 | _( UNDBAR2, '_', 1, "f", "_" ) \ 146 | _( NABLA, MODE1('g'), 1, "g", /*U+2207*/ "\xe2\x88\x87" ) \ 147 | _( INCREMENT, MODE1('h'), 1, "h", /*U+2206*/ "\xe2\x88\x86" ) \ 148 | _( RING, MODE1('j'), 1, "j", /*U+2218*/ "\xe2\x88\x98" ) \ 149 | _( KWOTE, '\'', 1, "k", "'" ) \ 150 | _( QUAD, MODE1('l'), 1, "l", /*U+2395*/ "\xe2\x8e\x95" ) \ 151 | _( SUBSET, MODE1('z'), 1, "z", /*U+2282*/ "\xe2\x8a\x82" ) \ 152 | _( SUPERSET, MODE1('x'), 1, "x", /*U+2283*/ "\xe2\x8a\x83" ) \ 153 | _( CAP, MODE1('c'), 1, "c", /*U+2229*/ "\xe2\x88\xa9" ) \ 154 | _( CUP, MODE1('v'), 1, "v", /*U+222a*/ "\xe2\x88\xaa" ) \ 155 | _( UPTACK, MODE1('b'), 1, "b", /*U+22a5*/ "\xe2\x8a\xa5" ) \ 156 | _( DNTACK, MODE1('n'), 1, "n", /*U+22a4*/ "\xe2\x8a\xa4" ) \ 157 | _( DIVIDES, MODE1('m'), 1, "m", /*U+2223*/ "\xe2\x88\xa3" ) \ 158 | _( DOT, MODE1('~'), 1, "~", ESC(n)"~""\xE" ) \ 159 | _( DIAMOND, MODE1('`'), 1, "`", ESC(n)"`""\xE" ) \ 160 | _( PI, MODE1('{'), 1, "{", ESC(n)"{""\xE" ) \ 161 | _( POUND, MODE1('}'), 1, "}", ESC(n)"}""\xE" ) \ 162 | _( EURO, MODE1('e'), 1, "e", "\xe2\x82\xac" ) \ 163 | _( CENT, MODE1('e'), 1, "e", ESC(o)"\"""\xE" ) \ 164 | _( YEN, MODE1('d'), 1, "d", ESC(o)"%""\xE" ) \ 165 | _( HBAR0, MODE1('o'), 1, "o", ESC(n)"o""\xE" ) \ 166 | _( HBAR1, MODE1('p'), 1, "p", ESC(n)"p""\xE" ) \ 167 | _( HBAR3, MODE1('q'), 1, "q", ESC(n)"q""\xE" ) \ 168 | _( HBAR4, MODE1('r'), 1, "r", ESC(n)"r""\xE" ) \ 169 | _( HBAR5, MODE1('s'), 1, "s", ESC(n)"s""\xE" ) \ 170 | _( GRAYBOX, MODE1('a'), 1, "a", ESC(n)"a""\xE" ) \ 171 | _( DEGREE, MODE1('f'), 1, "f", ESC(n)"f""\xE" ) \ 172 | _( HT, '\x9', 0, "\t", ESC(n)"b""\xE" ) \ 173 | _( NL, '\xa', 0, "\n", ESC(n)"h""\xE" ) \ 174 | _( LF, '\xa', 0, "\n", ESC(n)"e""\xE" ) \ 175 | _( VT, '\xb', 0, "\v", ESC(n)"i""\xE" ) \ 176 | _( FF, '\xc', 0, "\f", ESC(n)"c""\xE" ) \ 177 | _( CR, '\xd', 0, "\r", ESC(n)"d""\xE" ) \ 178 | _( JUNCL, MODE1('m'), 1, "m", ESC(n)"m""\xE" ) \ 179 | _( JUNCJ, MODE1('j'), 1, "j", ESC(n)"j""\xE" ) \ 180 | _( JUNCK, MODE1('k'), 1, "k", ESC(n)"k""\xE" ) \ 181 | _( JUNCR, MODE1('l'), 1, "l", ESC(n)"l""\xE" ) \ 182 | _( VBAR, MODE1('x'), 1, "x", ESC(n)"x""\xE" ) \ 183 | _( JUNCF, MODE1('t'), 1, "t", ESC(n)"t""\xE" ) \ 184 | _( JUNC3, MODE1('u'), 1, "u", ESC(n)"u""\xE" ) \ 185 | _( JUNCT, MODE1('w'), 1, "w", ESC(n)"n""\xE" ) \ 186 | _( JUNCM, MODE1('n'), 1, "n", ESC(n)"w""\xE" ) \ 187 | _( JUNCW, MODE1('b'), 1, "b", ESC(n)"v""\xE" ) \ 188 | /* ALPHA_NAME base ext input output */ \ 189 | _( INVEXCL, MODE1('!'), 1, "!", ESC(o)"!""\xE" ) /* "uk" chars patch */ \ 190 | _( INVQUEST, MODE1('?'), 1, "?", ESC(o)"?""\xE" ) \ 191 | _( GUILLEFT, MODE1('<'), 1, "<", ESC(o)"+""\xE" ) \ 192 | _( GUILRIGHT, MODE1('>'), 1, ">", ESC(o)";""\xE" ) \ 193 | _( COMPL, MODE1('^'), 1, "^", ESC(o)",""\xE" ) \ 194 | _( TIMES, MODE1('='), 1, "=", ESC(o)"W""\xE" ) \ 195 | _( DIVIDE, MODE1('/'), 1, "/", ESC(o)"w""\xE" ) \ 196 | _( CDOT, MODE1('.'), 1, ".", ESC(o)"7""\xE" ) \ 197 | _( HYPHEN, MODE1('-'), 1, "-", ESC(o)"-""\xE" ) \ 198 | _( BUTTON, MODE1('i'), 1, "i", ESC(o)"$""\xE" ) \ 199 | _( SECTION, MODE1('h'), 1, "h", ESC(o)"'""\xE" ) \ 200 | _( PRIME, MODE1('\''), 1, "'", ESC(o)"4""\xE" ) \ 201 | _( CIRCC, MODE1('c'), 1, "c", ESC(o)")""\xE" ) \ 202 | _( ZEROSLASH, MODE1('v'), 1, "v", ESC(o)"X""\xE" ) \ 203 | _( OBAR, MODE1(';'), 1, ";", ESC(o)":""\xE" ) \ 204 | /* ALPHA_NAME base ext input output */ \ 205 | _( PARAGRAPH, MODE1(','), 1, ",", ESC(o)"6""\xE" ) \ 206 | _( BARA, MODE1('@'), 1, "@", ESC(o)"*""\xE" ) \ 207 | _( CIRCR, MODE1('#'), 1, "#", ESC(o)".""\xE" ) \ 208 | _( MU, MODE1('$'), 1, "$", ESC(o)"5""\xE" ) \ 209 | _( COLONBAR, MODE1('+'), 1, "+", ESC(o)"w""\xE" ) \ 210 | _( DEL, MODE1('&'), 1, "&", ESC(o)"P""\xE" ) \ 211 | _( SUPONE, MODE1('('), 1, "(", ESC(o)"9""\xE" ) \ 212 | _( SUPTWO, MODE1(')'), 1, ")", ESC(o)"2""\xE" ) \ 213 | /*_( SUPTHREE, MODE1('+'), 1, "+", ESC(o)"1""\xE" )*/ \ 214 | _( a1, 'a', 1, "a", "a" ) /* fallback: basic latin alphabet */ \ 215 | _( b1, 'b', 1, "b", "b" ) \ 216 | _( c1, 'c', 1, "c", "c" ) \ 217 | _( d1, 'd', 1, "d", "d" ) \ 218 | _( e1, 'e', 1, "e", "e" ) \ 219 | _( f1, 'f', 1, "f", "f" ) \ 220 | _( g1, 'g', 1, "g", "g" ) \ 221 | _( h1, 'h', 1, "h", "h" ) \ 222 | _( i1, 'i', 1, "i", "i" ) \ 223 | _( j1, 'j', 1, "j", "j" ) \ 224 | _( k1, 'k', 1, "k", "k" ) \ 225 | _( l1, 'l', 1, "l", "l" ) \ 226 | _( m1, 'm', 1, "m", "m" ) \ 227 | _( n1, 'n', 1, "n", "n" ) \ 228 | _( o1, 'o', 1, "o", "o" ) \ 229 | _( p1, 'p', 1, "p", "p" ) \ 230 | _( q1, 'q', 1, "q", "q" ) \ 231 | _( r1, 'r', 1, "r", "r" ) \ 232 | _( s1, 's', 1, "s", "s" ) \ 233 | _( t1, 't', 1, "t", "t" ) \ 234 | _( u1, 'u', 1, "u", "u" ) \ 235 | _( v1, 'v', 1, "v", "v" ) \ 236 | _( w1, 'w', 1, "w", "w" ) \ 237 | _( x1, 'x', 1, "x", "x" ) \ 238 | _( y1, 'y', 1, "y", "y" ) \ 239 | _( z1, 'z', 1, "z", "z" ) \ 240 | _( A1, 'A', 1, "A", "A" ) \ 241 | _( B1, 'B', 1, "B", "B" ) \ 242 | _( C1, 'C', 1, "C", "C" ) \ 243 | _( D1, 'D', 1, "D", "D" ) \ 244 | _( E1, 'E', 1, "E", "E" ) \ 245 | _( F1, 'F', 1, "F", "F" ) \ 246 | _( G1, 'G', 1, "G", "G" ) \ 247 | _( H1, 'H', 1, "H", "H" ) \ 248 | _( I1, 'I', 1, "I", "I" ) \ 249 | _( J1, 'J', 1, "J", "J" ) \ 250 | _( K1, 'K', 1, "K", "K" ) \ 251 | _( L1, 'L', 1, "L", "L" ) \ 252 | _( M1, 'M', 1, "M", "M" ) \ 253 | _( N1, 'N', 1, "N", "N" ) \ 254 | _( O1, 'O', 1, "O", "O" ) \ 255 | _( P1, 'P', 1, "P", "P" ) \ 256 | _( Q1, 'Q', 1, "Q", "Q" ) \ 257 | _( R1, 'R', 1, "R", "R" ) \ 258 | _( S1, 'S', 1, "S", "S" ) \ 259 | _( T1, 'T', 1, "T", "T" ) \ 260 | _( U1, 'U', 1, "U", "U" ) \ 261 | _( V1, 'V', 1, "V", "V" ) \ 262 | _( W1, 'W', 1, "W", "W" ) \ 263 | _( X1, 'X', 1, "X", "X" ) \ 264 | _( Y1, 'Y', 1, "Y", "Y" ) \ 265 | _( Z1, 'Z', 1, "Z", "Z" ) \ 266 | _( PLUS1, '+', 1, "+", "+" ) /* fallback: ascii punctuation */ \ 267 | _( MINUS1, '-', 1, "-", "-" ) \ 268 | _( EQUAL1, '=', 1, "=", "=" ) \ 269 | _( UNDERSCORE1, '_', 1, "_", "_" ) \ 270 | _( LBRACE1, '{', 1, "{", "{" ) \ 271 | _( RBRACE1, '}', 1, "}", "}" ) \ 272 | _( PIPE1, '|', 1, "|", "|" ) \ 273 | _( LBRACKET1, '[', 1, "[", "[" ) \ 274 | _( RBRACKET1, ']', 1, "]", "]" ) \ 275 | _( BACKSLASH1, '\\', 1, "\\", "\\" ) \ 276 | _( COLON1, ':', 1, ":", ":" ) \ 277 | _( SEMICOLON1, ';', 1, ";", ";" ) \ 278 | _( QUOTE1, '\'', 1, "'", "'" ) \ 279 | _( DBLQUOTE1, '"', 1, "\"", "\"" ) \ 280 | _( COMMA1, ',', 1, ",", "," ) \ 281 | _( PERIOD1, '.', 1, ".", "." ) \ 282 | _( SLASH1, '/', 1, "/", "/" ) \ 283 | _( LANG1, '<', 1, "<", "<" ) \ 284 | _( RANG1, '>', 1, ">", ">" ) \ 285 | _( QUESTION1, '?', 1, "?", "?" ) \ 286 | _( TILDE1, '~', 1, "~", "~" ) \ 287 | _( BACKQUOTE1, '`', 1, "`", "`" ) \ 288 | _( EXCL1, '!', 1, "!", "!" ) \ 289 | _( AT1, '@', 1, "@", "@" ) \ 290 | _( HASH1, '#', 1, "#", "#" ) \ 291 | _( DOLLAR1, '$', 1, "$", "$" ) \ 292 | _( PERCENT1, '%', 1, "%", "%" ) \ 293 | _( CARET1, '^', 1, "^", "^" ) \ 294 | _( AMPERSAND1, '&', 1, "&", "&" ) \ 295 | _( STAR1, '*', 1, "*", "*" ) \ 296 | _( LPAREN1, '(', 1, "(", "(" ) \ 297 | _( RPAREN1, ')', 1, ")", ")" ) \ 298 | /* ALPHA_NAME base ext input output */ \ 299 | _( NULLCHAR, 0, 0, 0, 0 ) 300 | #define ALPHATAB_ENT(a,...) {__VA_ARGS__}, 301 | struct alpha{int base;int ext;char*input;char*output;}alphatab[]={ALPHATAB(ALPHATAB_ENT)}; 302 | #define ALPHATAB_NAME(a,...) ALPHA_ ## a , 303 | enum alphaname { ALPHATAB(ALPHATAB_NAME) }; /* NB. ALPHA_NAME!=alphatab[ALPHA_NAME].base */ 304 | -------------------------------------------------------------------------------- /icecream: -------------------------------------------------------------------------------- 1 | a<0} './inca2 < icecream' 2 | h:y%2 3 | q:y-hn-1 4 | i:[((n%2)^2)>+/(qx y)^2 5 | j:(~[y%2)i.(~y) 6 | k:2*[x>[|qy 7 | l:(@1+~]y%2)k.(~y) 8 | c:y y#((jn int(object) 3 | 4 | object ... object <-Array-> object 5 | 6 | object(key) * Symtab-> object(val) 7 | 8 | object(a) object(w) Verb-> object(z) 9 | 10 | object(a) object(w) Adverb-> verb(z) 11 | 12 | 13 | Numeric types 14 | -- 15 | 16 | integer 17 | GMP multiprecision integer 18 | MPFR multiprecision floating point 19 | 20 | The math functions should seamlessly promote results into the larger 21 | types as necessary. There are no syntactic decorations for numbers 22 | to indicate or request the multiprecision handling. It should be 23 | automatic. 24 | 25 | 26 | Object types 27 | -- 28 | 29 | The data structures of the interpreter are built out of a fairly 30 | low-level view of data. The `object` type is defined as a 32bit 31 | integer. We select a few bits from the top to treat as a `tag` and 32 | restrict our language's integer type to the remaining value bits, 33 | excluding the tag. 34 | 35 | The tag indicates the meaning of the value bits. Tags such as 36 | LITERAL, CHAR, PCHAR (executable char), LABEL, use the integer 37 | value in the obvious way. 38 | 39 | Other tags are "indexed" and map to a pointer through an array 40 | of expanding arrays of `void*`. This is wrapped by a function, 41 | `void *getptr(object d)` but proceeds very simply: 42 | 43 | memory_bank[gettag(d) - FIRST_INDEXED_TYPE].tab[getval(d)]; 44 | 45 | For interoperability, all array extents should be limited to 46 | the range of an integer literal, or 2^24. 47 | -------------------------------------------------------------------------------- /olmec/Dresden43b.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/luser-dr00g/inca/d369b9827158a6bb7caca9d2b85bef23e0cdf3fe/olmec/Dresden43b.jpg -------------------------------------------------------------------------------- /olmec/adverb.tab: -------------------------------------------------------------------------------- 1 | #include "adverbs.h" 2 | 3 | #define nnone _ 4 | #define mnone _ 5 | #define dnone _ 6 | #define PRINT_ADVERB_TABLE(param,base, fnilad,fmonad,fdyad, f,g,h, m,l,r, mdesc, ddesc) \ 7 | base | fmonad | mdesc | fdyad | ddesc EOL 8 | ADVERBS_FOREACH(0,PRINT_ADVERB_TABLE) 9 | #undef nnone 10 | #undef mnone 11 | #undef dnone 12 | #undef PRINT_ADVERB_TABLE 13 | -------------------------------------------------------------------------------- /olmec/adverb_private.h: -------------------------------------------------------------------------------- 1 | 2 | enum { NN, NV, VN, VV }; 3 | #define CONJCASE(a,w) \ 4 | (qverb(a)*2+qverb(w)) 5 | 6 | 7 | -------------------------------------------------------------------------------- /olmec/adverbs.c: -------------------------------------------------------------------------------- 1 | /* Adverbs and Conjunctions 2 | * 3 | * These re-use the same structure as verbs, and generate 4 | * new verb structures dynamically for a concrete representation 5 | * of a "derived verb" which is the result of an adverb or conjunction. 6 | * 7 | * That is, these functions take other functions (verbs) as arguments. 8 | * 9 | * & amp implements currying a left or right argument to a function, 10 | * yielding a monadic derived verb. For 2 verbs it creates a 11 | * derived verb which is the composition f o g. 12 | * 13 | * @ atop performs a similar but simpler f o g composition. 14 | * 15 | * / areduce yields a derived verb which is a reduction wrt the argument verb. 16 | * 17 | * \ ascan yields a derived verb which is yields a series of partial reductions 18 | * of increasing prefixes of the argument. 19 | * 20 | * abackscan behaves like ascan but yields the partial reductions of decreasing 21 | * suffixes of the argument (`back`wards `scan`) 22 | */ 23 | #include 24 | #include 25 | 26 | #include "array.h" 27 | #include "encoding.h" 28 | #include "symtab.h" 29 | #include "verbs.h" 30 | #include "exec.h" 31 | #include "print.h" 32 | 33 | #include "adverbs.h" 34 | #include "adverb_private.h" 35 | 36 | typedef struct vtable { 37 | verb fv; 38 | monad *f1; 39 | dyad *f2; 40 | verb gv; 41 | monad *g1; 42 | dyad *g2; 43 | } vtable; 44 | vtable loadv(verb v){ 45 | verb fv = getptr(v->f); 46 | monad *f1 = fv?fv->monad:0; 47 | dyad *f2 = fv?fv->dyad:0; 48 | verb gv = getptr(v->g); 49 | monad *g1 = gv?gv->monad:0; 50 | dyad *g2 = gv?gv->dyad:0; 51 | return (vtable){fv,f1,f2,gv,g1,g2}; 52 | } 53 | 54 | object create_derived_verb( 55 | object id, 56 | nilad *nilad, 57 | monad *monad, 58 | dyad *dyad, 59 | object f, object g, object h, 60 | int mr, int lr, int rr){ 61 | verb v = malloc(sizeof*v); 62 | *v = (struct verb){ newdata(PCHAR, id), nilad, monad, dyad, f, g, h, mr, lr, rr}; 63 | return cache(VERB, v); 64 | } 65 | 66 | object domerr(object w, verb v){ 67 | return null; 68 | } 69 | 70 | object withl(object w, verb v){ vtable vt=loadv(v); return vt.g2(v->f, w, vt.gv); } 71 | object withr(object w, verb v){ vtable vt=loadv(v); return vt.f2(w, v->g, vt.fv); } 72 | object on1(object w, verb v){ vtable vt=loadv(v); return vt.f1(vt.g1(w,vt.gv),vt.fv); } 73 | object on2(object a, object w, verb v){ vtable vt=loadv(v); return vt.f2(vt.g1(a,vt.gv),vt.g1(w,vt.gv),vt.fv); } 74 | 75 | object amp(object a, object w, verb v){ 76 | switch(CONJCASE(a,w)){ 77 | case NN: return domerr(0,v); 78 | case NV: return create_derived_verb('&', NULL, withl, NULL, a, w, 0, 0, 0, 0); 79 | case VN: return create_derived_verb('&', NULL, withr, NULL, a, w, 0, 0, 0, 0); 80 | case VV: return create_derived_verb('&', NULL, on1, on2, a, w, 0, 0, 0, 0); 81 | } 82 | } 83 | 84 | 85 | object atop2(object a, object w, verb v){ vtable vt=loadv(v); return vt.f1(vt.g2(a,w,vt.gv),vt.fv); } 86 | 87 | object atop(object a, object w, verb v){ 88 | switch(CONJCASE(a,w)){ 89 | case NN: return domerr(0,v); 90 | case NV: return domerr(0,v); 91 | case VN: return domerr(0,v); 92 | case VV: { 93 | v = getptr(w); 94 | return create_derived_verb('@', NULL, on1, atop2, a, w, 0, v->mr, v->lr, v->rr); 95 | } 96 | } 97 | } 98 | 99 | 100 | object reduce(object w, verb v){ 101 | vtable vt=loadv(v); 102 | switch(gettag(w)){ 103 | case NUMBER: 104 | case LITERAL: return w; 105 | case ARRAY: { 106 | array W = getptr(w); 107 | switch(W->rank){ 108 | case 1: switch(W->dims[0]){ 109 | case 0: return getfill(vt.fv->id); 110 | case 1: return *elem(W,0); 111 | default: { 112 | #if 0 113 | int z=*elem(W,W->dims[0]-1); 114 | for (int i=W->dims[0]-2; i>=0; i--) 115 | z=f2(*elem(W,i),z,v); 116 | #endif 117 | return vt.f2(*elem(W,0), reduce(vdrop(1,w,v), v), v); 118 | } 119 | } 120 | } 121 | } 122 | } 123 | return null; 124 | } 125 | 126 | object areduce(object w, verb v){ 127 | return create_derived_verb('/', NULL, reduce, 0, w, 0, 0, 0, 0, 0); 128 | } 129 | 130 | 131 | object scan(object w, verb v){ 132 | vtable vt=loadv(v); 133 | switch(gettag(w)){ 134 | case NUMBER: 135 | case LITERAL: return w; 136 | case ARRAY: { 137 | array W = getptr(w); 138 | switch(W->rank){ 139 | case 1: switch(W->dims[0]){ 140 | case 0: return getfill(vt.fv->id); 141 | case 1: return *elem(W,0); 142 | default: { 143 | array z = array_new_rank_pdims(W->rank, W->dims); 144 | int n = W->dims[0]; 145 | #if 0 146 | *elem(z,0) = *elem(W,0); 147 | for (int i=1; irank){ 174 | case 1: switch(W->dims[0]){ 175 | case 0: return getfill(vt.fv->id); 176 | case 1: return *elem(W,0); 177 | default: { 178 | array z = array_new_rank_pdims(W->rank, W->dims); 179 | int n = W->dims[0]; 180 | for (int i=0; idims[0]){ 204 | default: 205 | case 0: return null; 206 | case 1: return 207 | create_derived_verb(getval(va->id), 208 | va->nilad, va->monad, va->dyad, 209 | 0, 0, 0, *elem(W,0), *elem(W,0), *elem(W,0)); 210 | case 2: return 211 | create_derived_verb(getval(va->id), 212 | va->nilad, va->monad, va->dyad, 213 | 0, 0, 0, *elem(W,1), *elem(W,0), *elem(W,1)); 214 | case 3: return 215 | create_derived_verb(getval(va->id), 216 | va->nilad, va->monad, va->dyad, 217 | 0, 0, 0, *elem(W,0), *elem(W,1), *elem(W,2)); 218 | } 219 | } 220 | case VV: { 221 | verb va = getptr(a); 222 | verb vw = getptr(w); 223 | return create_derived_verb(getval(va->id), 224 | va->nilad, va->monad, va->dyad, 225 | va->f, va->g, va->h, vw->mr, vw->lr, vw->rr); 226 | } 227 | } 228 | } 229 | 230 | /* 231 | * del f 232 | * del f ; x 233 | * del z <- f 234 | * del z <- f ; x 235 | * del f w 236 | * del f w ; x 237 | * del z <- f w 238 | * del z <- f w ; x 239 | * del z <- a f w 240 | * del z <- a f w ; x 241 | * [0] 1 2 3 4 5 6 7 242 | * ^ $ 243 | */ 244 | analysis analyze_header(array head){ 245 | int exp,semi; 246 | analysis a = malloc(sizeof*a); 247 | 248 | for (exp=1; expdims[0]; ++exp){ 249 | if (qassn(*elem(head, exp))) { 250 | ++exp; 251 | break; 252 | } 253 | } 254 | 255 | if (a->result = (exp==3 && exp!=head->dims[0])){ 256 | a->resultvar = *elem(head, 1); 257 | } else { 258 | exp = 1; 259 | } 260 | DEBUG(1, "%s result\n", a->result?"has":"no"); 261 | 262 | for (semi=1; semidims[0]; ++semi){ 263 | if (qsemi(*elem(head, semi))) 264 | break; 265 | } 266 | 267 | if (a->extra = semi!=head->dims[0]){ 268 | a->extravars = cache(ARRAY, 269 | slices(head, (int[]){semi+1}, (int[]){head->dims[0]-1})); 270 | } 271 | DEBUG(1, "%s extra vars\n", a->extra?"has":"no"); 272 | 273 | switch(semi - exp){ 274 | default: printf("invalid del header\n"); 275 | case 1: //niladic 276 | a->arity = 0; 277 | a->func = *elem(head, exp); 278 | DEBUG(1, "niladic del\n"); 279 | break; 280 | case 2: //monadic 281 | a->arity = 1; 282 | a->func = *elem(head, exp); 283 | a->omega = *elem(head, exp+1); 284 | DEBUG(1, "monadic del\n"); 285 | break; 286 | case 3: //dyadic 287 | a->arity = 2; 288 | a->alpha = *elem(head, exp); 289 | a->func = *elem(head, exp+1); 290 | a->omega = *elem(head, exp+2); 291 | DEBUG(1, "dyadic del\n"); 292 | } 293 | return a; 294 | } 295 | 296 | object del(array head, array body, symtab env, symtab child){ 297 | analysis a = analyze_header(head); 298 | object v = create_derived_verb( 'G', 299 | a->arity==0? ndel : 0, 300 | a->arity==1? mdel : 0, 301 | a->arity==2? ddel : 0, 302 | cache(BLOCK, body), cache(SYMTAB, child), cache(ANALYSIS, a), 303 | 0, 0, 0); 304 | def(env, a->func, v,0); 305 | return v; 306 | } 307 | 308 | int contains(object needle, object haystack){ 309 | switch (gettag(haystack)){ 310 | case PCHAR: 311 | return needle == haystack; 312 | case ARRAY: 313 | case PROG: 314 | { 315 | array a = getptr(haystack); 316 | for (int i=0; idims[0]; i++){ 317 | if (contains(needle, *elem(a, i))) 318 | return 1; 319 | } 320 | } 321 | } 322 | return 0; 323 | } 324 | 325 | object dfn(object w, symtab env){ 326 | DEBUG(1, "dfn %08x(%d,%d)\n", w, gettag(w), getval(w)); 327 | IFDEBUG(1, print(w, 0, 1);); 328 | int has_alpha = contains(newdata(PCHAR, 0x237a), w); 329 | int has_omega = contains(newdata(PCHAR, 0x2375), w); 330 | return create_derived_verb( 'D', 331 | !has_alpha && !has_omega ? ndfn : 0, 332 | !has_alpha && has_omega ? mdfn : 0, 333 | has_alpha && has_omega ? ddfn : 0, 334 | w, cache(SYMTAB, env), 0, 335 | 0, 0, 0); 336 | } 337 | 338 | 339 | void adverbtab_def( 340 | object id, 341 | nilad *nilad, 342 | monad *monad, 343 | dyad *dyad, 344 | object f, object g, object h, /* operator arguments */ 345 | int mr, int lr, int rr, /* monadic,left,right rank*/ 346 | symtab st){ 347 | verb v; 348 | v=malloc(sizeof*v); 349 | *v=(struct verb){newdata(PCHAR, id), nilad, monad, dyad, f,g,h, mr,lr,rr}; 350 | def(st, newdata(PCHAR, id), cache(ADVERB, v),0); 351 | } 352 | 353 | #define ADVERBTAB_DEF(st, id, nil,mon,dy, f,g,h, m,l,r,...) \ 354 | adverbtab_def(id, nil,mon,dy, f,g,h, m,l,r, st); 355 | 356 | void init_av(symtab env){ 357 | #define nnone 0 358 | #define mnone 0 359 | #define dnone 0 360 | ADVERBS_FOREACH(env, ADVERBTAB_DEF) 361 | #undef nnone 362 | #undef mnone 363 | #undef dnone 364 | } 365 | 366 | -------------------------------------------------------------------------------- /olmec/adverbs.h: -------------------------------------------------------------------------------- 1 | #include "common.h" 2 | 3 | #define ADVERBS_FOREACH(param,_) \ 4 | /* base, nilad, monad, dyad, f, g, h, mr,lr,rr,mdesc,ddesc*/ \ 5 | _(param,'&', nnone, mnone, amp, 0, 0, 0, 0, 0, 0, \ 6 | none, compose functions or curry argument) \ 7 | _(param,'@', nnone, mnone, atop, 0, 0, 0, 0, 0, 0, \ 8 | none, compose functions ) \ 9 | _(param,'/', nnone, areduce, dnone, 0, 0, 0, 0, 0, 0, \ 10 | reduce using verb, none) \ 11 | _(param,'\\', nnone, ascan, dnone, 0, 0, 0, 0, 0, 0, \ 12 | scan using verb, none) \ 13 | _(param,0x2340, nnone, abackscan, dnone, 0, 0, 0, 0, 0, 0, \ 14 | scan right-to-left using verb, none) \ 15 | _(param,0x00a8, nnone, mnone, rank, 0, 0, 0, 0, 0, 0, \ 16 | none, derive new verb with specified or borrowed rank) \ 17 | /**/ 18 | /* see verbs.h for struct verb {} def */ 19 | 20 | #define nnone vnil 21 | #define mnone areduce 22 | #define dnone amp 23 | #define DECLARE_ADVERB_FUNCTIONS(param,id, fnilad, fmonad, fdyad, ...) \ 24 | nilad fnilad; \ 25 | monad fmonad; \ 26 | dyad fdyad; 27 | ADVERBS_FOREACH(0,DECLARE_ADVERB_FUNCTIONS) 28 | #undef nnone 29 | #undef mnone 30 | #undef dnone 31 | #undef DECLARE_ADVERB_FUNCTIONS 32 | 33 | typedef struct { /* information gleaned from del func header line */ 34 | int result; 35 | object resultvar; 36 | int arity; 37 | object alpha; 38 | object func; 39 | object omega; 40 | int extra; 41 | object extravars; 42 | } *analysis; 43 | 44 | object del(array head, array body, symtab env, symtab child); 45 | object dfn(object w, symtab env); 46 | object amp(object a, object w, verb v); 47 | object rank(object a, object w, verb v); 48 | void init_av(symtab st); 49 | 50 | -------------------------------------------------------------------------------- /olmec/all_tests.m4: -------------------------------------------------------------------------------- 1 | divert(`-1') 2 | # http://www.gnu.org/savannah-checkouts/gnu/m4/manual/m4-1.4.17/html_node/Foreach.html#Foreach 3 | # foreach(x, (item_1, item_2, ..., item_n), stmt) 4 | # parenthesized list, simple version 5 | define(`foreach', `pushdef(`$1')_foreach($@)popdef(`$1')') 6 | define(`_arg1', `$1') 7 | define(`_foreach', `ifelse(`$2', `()', `', 8 | `define(`$1', _arg1$2)$3`'$0(`$1', (shift$2), `$3')')') 9 | 10 | define(`UNITS', (patsubst(UNITS,`\W',`,'))) 11 | 12 | divert`'dnl 13 | /* This file is automatically generated by $ m4 all_tests.m4 >all_tests,c */ 14 | int tests_run; 15 | 16 | `#' include 17 | foreach(`unit', UNITS, ` 18 | `#' define main unit`'_main 19 | `#' define tests_run unit`'_tests_run 20 | `#' define all_tests unit`'_all_tests 21 | `#' include "unit`'_test.c" 22 | `#' undef main 23 | `#' undef tests_run 24 | `#' undef all_tests 25 | int unit`'_test(){ 26 | int ret; 27 | printf("---------------\n"); 28 | printf("running unit`'_test\n"); 29 | ret = unit`'_main(); 30 | tests_run += unit`'_tests_run; 31 | return ret; 32 | } 33 | ')dnl 34 | 35 | int main(){ 36 | int ret; 37 | ret = 0 foreach(`unit', UNITS, ` || unit`'_test() ') ; 38 | printf("Grand Total tests run: %d\n", tests_run); 39 | return ret; 40 | } 41 | 42 | -------------------------------------------------------------------------------- /olmec/array.h: -------------------------------------------------------------------------------- 1 | #ifndef ARRAY_H_ 2 | #define ARRAY_H_ 3 | #include "common.h" 4 | 5 | struct array { 6 | int type; 7 | enum { 8 | none = 0, 9 | temp = 1, 10 | } flag; 11 | int rank; // number of dimensions 12 | int *dims; // size of each dimension 13 | int cons; // constant term of the indexing formula 14 | int *weight; // corresponding coefficient in the indexing formula 15 | int **translate; // optional index-translation vector for complex slices 16 | object *data; // address of first array element 17 | int *(*func)(array,int); // data function (if function type) 18 | }; 19 | 20 | enum type { 21 | normal, 22 | indirect, 23 | function 24 | }; 25 | 26 | extern array nilarray; 27 | void init_array(void); 28 | 29 | int productdims(int rank, const int *dims); 30 | array array_new_rank_pdims(int rank, const int *dims); // type=normal 31 | 32 | void loaddimsv(int rank, int *dims, va_list ap); 33 | array (array_new_rank_dims)(int rank, ...); // type=normal 34 | #define array_new_dims(...) (array_new_rank_dims)(PP_NARG(__VA_ARGS__),__VA_ARGS__) 35 | 36 | int *constant(array a,int idx); 37 | int *j_vector(array a,int idx); 38 | array array_new_function(int rank, const int *dims, 39 | const int *data, int datan, int *(*func)(array,int)); // type=function 40 | 41 | array cast_rank_pdims(int *data, int rank, const int *dims); // type=indirect 42 | array (cast_rank_dims)(int *data, int rank, ...); // type=indirect 43 | #define cast_dims(data,...) (cast_rank_dims)(data,PP_NARG(__VA_ARGS__),__VA_ARGS__) 44 | 45 | array clone(array a); // type=indirect 46 | array copy(array a); // type=normal 47 | int issolid(array a); 48 | array makesolid(array a); // type=normal 49 | 50 | int *vector_index(int ind, const int *dims, int n, int *vec); 51 | int ravel_index(const int *vec, const int *dims, int n); 52 | object *elemr(array a, int idx); 53 | object *elema(array a, const int *ind); 54 | object *elemv(array a, va_list ap); 55 | object *elem(array a, ...); 56 | 57 | void transpose2(array a); 58 | void transpose(array a, int shift); 59 | void transposea(array a, const int *spec); 60 | 61 | array slice(array a, int i); // type=indirect 62 | array slicea(array a, const int *spec); // type=indirect 63 | array slices(array a, const int *s, const int *f); // type=indirect 64 | array slicec(array a, array *spec); 65 | 66 | array extend(array a, int extra); // type=indirect 67 | 68 | array scalar(int n); 69 | array (vector_n)(int n, ...); 70 | #define vector(...) (vector_n)(PP_NARG(__VA_ARGS__),__VA_ARGS__) 71 | 72 | array cat(array x, array y); 73 | array iota(int n); // type=function 74 | 75 | #endif 76 | -------------------------------------------------------------------------------- /olmec/array_test.c: -------------------------------------------------------------------------------- 1 | #define TESTMODULE 2 | #include "array.c" 3 | -------------------------------------------------------------------------------- /olmec/common.h: -------------------------------------------------------------------------------- 1 | /* 2 | * The central concept of encoding data is the use of the basic `int` type 3 | * for "everything". We chop the 32 bits into an 8 bit tag[*] and 24 bit value. 4 | * So we can't deal with literal numbers that are larger than 16.7 million 5 | * or so. 6 | * 7 | * An `int` which contains one of our encoded-integer values should be 8 | * declared `object` to convey this semantics to the reader. 9 | * Conversely, having determined that an object's tag is LITERAL, 10 | * code may feel free to treat it as a restricted-range integer value. 11 | * 12 | * [*] since we treat negative numbers as encoding to themselves, in essence 13 | * we only have a 7bit tag to play with. 14 | */ 15 | 16 | #ifndef COMMON_H_ 17 | #define COMMON_H_ 18 | 19 | #include 20 | #include 21 | #include 22 | #include "../ppnarg.h" 23 | 24 | #define MODE1(x) (x+(1<<7)) //add hi bit of ascii char 25 | 26 | typedef int object; 27 | 28 | typedef union integer { 29 | uint32_t uint32; 30 | int32_t int32; 31 | } integer; 32 | 33 | enum tag { 34 | LITERAL, /* val is a 24-bit 2's comp integer */ 35 | CHAR, /* val is a 21-bit Unicode code point padded with zeros */ 36 | PCHAR, /* val is a an executable char */ 37 | MARKOBJ, /* val is irrelevant (s.b. 0) */ 38 | NULLOBJ, /* val is irrelevant (s.b. 0) */ 39 | 40 | LABEL, /* the statement number, counting from 1 */ 41 | LPAROBJ, 42 | RPAROBJ, 43 | SEMIOBJ, 44 | RBRACOBJ, 45 | 46 | FIRST_INDEXED_TYPE, 47 | NUMBER = FIRST_INDEXED_TYPE, /* val is an index in the number table */ 48 | PROG, /* val is an (index to an) executable code fragment (array of PCHAR)*/ 49 | ARRAY, /* val is a(n index to a) boxed array */ 50 | SYMTAB, /* val is a(n index to a) symbol table */ 51 | LBRACOBJ, /* val is an (index to an) array of the bracket contents */ 52 | 53 | ANALYSIS, /* del function header info */ 54 | MAGIC, /* get/set function pair */ 55 | VERB, /* val is a(n index to a) verb object */ 56 | ADVERB, /* val is a(n index to a) verb object */ 57 | XVERB, /* val is a(n index to a) struct containing a verb and adverb */ 58 | 59 | EXPR, /* val is a(n index to a) vector of the expression contents */ 60 | BLOCK, /* val is a(n index to a) vector of expressions, a PROGN */ 61 | LAST_INDEXED_TYPE = BLOCK, 62 | }; 63 | 64 | typedef struct array *array; 65 | 66 | typedef struct verb *verb; // also used for adverbs 67 | typedef object nilad(verb v); 68 | typedef object monad(object w,verb v); 69 | typedef object dyad(object a,object w,verb v); 70 | 71 | typedef struct xverb *xverb; 72 | 73 | typedef struct symtab *symtab; 74 | typedef struct magic *magic; 75 | 76 | #ifdef DEBUGMODE 77 | #define DEBUG(LVL,...) if (LVL<=DEBUGMODE) fprintf(stderr, __VA_ARGS__) 78 | #define IFDEBUG(LVL,...) do if (LVL<=DEBUGMODE) { __VA_ARGS__; } while(0) 79 | #else 80 | #define DEBUG(...) 81 | #define IFDEBUG(...) 82 | #endif 83 | 84 | #endif 85 | -------------------------------------------------------------------------------- /olmec/ed.c: -------------------------------------------------------------------------------- 1 | #define _POSIX_SOURCE 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include // log2 10 | //#include // ilog2 11 | 12 | 13 | /////////////////////////////////////////////////////////////////////////////// 14 | // 15 | // UTF-8 <-> UCS-4 processing 16 | // 17 | /////////////////////////////////////////////////////////////////////////////// 18 | 19 | // type to contain 1 utf-8 "character" up to 4 bytes 20 | // if b[4] is 0, then b is a string 21 | // 22 | typedef struct { 23 | int n; 24 | unsigned char b[5]; 25 | } utfcp; 26 | uint32_t to_ucs4(utfcp c); 27 | utfcp to_utf8(uint32_t u); 28 | 29 | // Unicode-defined replacement for miscoded chars 30 | #define REPLACEMENT 0xFFFD 31 | 32 | /* number of leading zeros of byte-sized value */ 33 | static int leading0s(uint_least32_t x){ return 7 - (x? floor(log2(x)): -1); } 34 | 35 | /* number of leading ones of byte-sized value */ 36 | #define leading1s(x) leading0s(0xFF^(x)) 37 | 38 | // rather than signal an error, 39 | // we pass this through to allow for a special encoding 40 | uint32_t expand_shortcut(unsigned char b){ 41 | return b; 42 | } 43 | 44 | uint32_t to_ucs4(utfcp c){ 45 | int prefix = leading1s(c.b[0]); 46 | int n = prefix? prefix: 1; 47 | uint32_t u; 48 | //printf("prefix:%d\n",n); 49 | //if (n != c.n) 50 | switch(prefix){ 51 | case 0: u = c.b[0]; break; 52 | case 1: return u = expand_shortcut(c.b[0]); 53 | case 2: u = c.b[0] & 0x1f; break; 54 | case 3: u = c.b[0] & 0x0f; break; 55 | case 4: u = c.b[0] & 0x07; break; 56 | } 57 | //printf("%04x\n", u); 58 | for(int i=1; i>6), 74 | 0x80|(u&0x3f)}; 75 | if (u<0x10000) return (utfcp){3,0xE0|(u>>12), 76 | 0x80|((u>>6)&0x3f),0x80|(u&0x3f)}; 77 | if (u<0x110000) return (utfcp){4,0xF0|(u>>18), 78 | 0x80|((u>>12)&0x3f),0x80|((u>>6)&0x3f),0x80|(u&0x3f)}; 79 | //(else) error RANGE 80 | return (utfcp){0,0}; 81 | } 82 | 83 | 84 | /////////////////////////////////////////////////////////////////////////////// 85 | // 86 | // Terminal handling 87 | // 88 | /////////////////////////////////////////////////////////////////////////////// 89 | 90 | 91 | struct termios saved_settings; 92 | 93 | void restore_terminal(void){ 94 | tcsetattr(0, TCSANOW, &saved_settings); 95 | } 96 | 97 | void init_terminal(void){ 98 | tcgetattr(0, &saved_settings); 99 | atexit(restore_terminal); 100 | 101 | struct termios raw_mode = saved_settings; 102 | 103 | raw_mode.c_iflag |= IGNPAR; //ignore parity errors 104 | raw_mode.c_iflag &= //non-canon, no echo, no kill 105 | ~(IGNBRK | PARMRK | ISTRIP | ICRNL | IXON | IXANY | IXOFF); 106 | 107 | raw_mode.c_lflag &= 108 | ~(ECHO | ECHOE | ECHOK | ECHONL | ICANON); 109 | 110 | raw_mode.c_cflag &= ~(CSIZE | PARENB); 111 | raw_mode.c_cflag |= CS8; 112 | 113 | raw_mode.c_oflag |= OPOST; //special output processing 114 | 115 | raw_mode.c_cc[VMIN] = 4; //min chars to read 116 | raw_mode.c_cc[VTIME] = 1; //timeout 117 | 118 | if (tcsetattr(0, TCSANOW, &raw_mode) == -1) 119 | perror("init_terminal"); 120 | } 121 | 122 | typedef struct { 123 | unsigned unicode; 124 | utfcp bytes; 125 | } character; 126 | 127 | // read up to 4 bytes from keyboard/stdin 128 | // and attempt to decode it as a utf-8 encoding 129 | // 130 | character read_character(void){ 131 | int len; 132 | char buf[5]; 133 | do { 134 | memset(buf, 0, sizeof buf); 135 | len = read(fileno(stdin), buf, 4); 136 | } while(len == -1 && errno == EAGAIN); 137 | //printf("%d:", len); 138 | //for (int i=0; ip++ = c.unicode; 180 | } 181 | 182 | 183 | 184 | /////////////////////////////////////////////////////////////////////////////// 185 | // 186 | // Key Handlers (Decoders) 187 | // 188 | /////////////////////////////////////////////////////////////////////////////// 189 | 190 | 191 | unsigned ignore(editor *ed, character c){ 192 | return 0; 193 | } 194 | 195 | unsigned eot(editor *ed, character c){ 196 | //printf("EOT\n"); 197 | print(c); 198 | character eod = { .unicode = 0x4, .bytes = { 1, 0x4 }}; 199 | store(ed, eod); 200 | return EOF; 201 | } 202 | 203 | unsigned bell(editor *ed, character c){ 204 | printf("ding!\n"); 205 | return c.unicode; 206 | } 207 | 208 | unsigned backspace(editor *ed, character c){ 209 | if (ed->p > ed->bufp){ 210 | printf("\b \b"), fflush(stdout); 211 | ed->p--; 212 | } 213 | return c.unicode; 214 | } 215 | 216 | unsigned tab(editor *ed, character c){ 217 | return c.unicode; 218 | } 219 | 220 | unsigned linefeed(editor *ed, character c){ 221 | printf("linefeed\n"); 222 | return c.unicode; 223 | } 224 | 225 | unsigned vtab(editor *ed, character c){ 226 | return c.unicode; 227 | } 228 | 229 | unsigned formfeed(editor *ed, character c){ 230 | return c.unicode; 231 | } 232 | 233 | unsigned carriage(editor *ed, character c){ 234 | //printf("carriage\n"); 235 | character nl = { .unicode = '\n', .bytes = { 1, '\n' }}; 236 | print(nl); 237 | store(ed, nl); 238 | return '\n'; 239 | } 240 | 241 | unsigned shiftout(editor *ed, character c){ 242 | return c.unicode; 243 | } 244 | 245 | unsigned shiftin(editor *ed, character c){ 246 | return c.unicode; 247 | } 248 | 249 | unsigned nak(editor *ed, character c){ 250 | return c.unicode; 251 | } 252 | 253 | // 254 | // The special APL keys accessed with ALT- or ESC+ 255 | // 256 | unsigned apl_alphabet[96] = { 257 | //SP ! " # $ % & ' 258 | // IBEAM DELTILD DELTASTIL DELSTIL CIRCSTIL CIRCBAR 259 | ' ', 0x2336, 0x236b, 0x234b, 0x2352, 0x233d, 0x2296, '\'', 260 | 261 | // ( ) * + , - . / 262 | //NOR NAND CIRCSTAR DOMINO COMMABAR TIMES ERGO SLASHBAR 263 | 0x2371, 0x2372, 0x235f, 0x2339, 0x236a, 0xd7, 0x2235, 0x233f, 264 | 265 | // 0 1 2 3 4 5 6 7 266 | // AND DIAERESIS MACRON LT|EQ GT|EQ 267 | 0x2227, 0xa8, 0xaf, '<', 0x2264, '=', 0x2265, '>', 268 | 269 | // 8 9 : ; < = > ? 270 | //NOTEQ OR << DIVIDES >> PILCROW 271 | 0x2260, 0x2228, ':', ';', 0xab, 0xf7, 0xbb, 0xb6, 272 | 273 | // @ A B C D E F G 274 | //DELTIL _ALPHA_ EXEC LAMP _EPS_ SAME DELTASTIL 275 | 0x236b, 0x2376, 0x234e, 0x235d, 'D', 0x2377, 0x2261, 0x234b, 276 | 277 | // H I J K L M N O 278 | //DELSTL _I_ DIAJOT 'QUAD FORMAT DIACIRC 279 | 0x2352, 0x2378, 0x2364, 'K', 0x235e, 'M', 0x2355, 0x2365, 280 | 281 | // P Q R S T U V W 282 | //POUND inv? REAL SQUISH TILSTL NULL PHI _OMEGA_ 283 | 0xa3, 0xbf, 0x211d, 0x2337, 0x236d, 0x2300, 0x2366, 0x2379, 284 | 285 | //X Y Z [ \ ] ^ _ 286 | // YEN SUBSTIL <- BACKBAR -> BACKCIRC 287 | 'X', 0xa5, 0x2367, 0x2190, 0x2340, 0x2192, 0x2349, '_', 288 | 289 | // ` a b c d e f g 290 | //DIAMOND ALPHA BASE CAP FLOOR EPSILON NABLA 291 | 0x22c4, 0x237a, 0x22a5, 0x2229, 0x230a, 0x2208, 'f', 0x2207, 292 | 293 | // h i j k l m n o 294 | //INCR IOTA JOT QUAD ENCODE CIRC 295 | 0x2206, 0x2373, 0x2218, 'k', 0x2395, 'm', 0x22a4, 0x25cb, 296 | 297 | // p q r s t u v w 298 | //STAR RHO CEIL DOWN CUP OMEGA 299 | 0x22c6, '?', 0x2374, 0x2308, '~', 0x2193, 0x222a, 0x2375, 300 | 301 | // x y z { | } ~ DEL 302 | //SUPER UP SUB LEFT RIGHT 303 | 0x2283, 0x2191, 0x2282, 0x22a3, '|', 0x22a2, '~', 0 304 | }; 305 | 306 | unsigned alpha(editor *ed, character c){ 307 | c.unicode = apl_alphabet[c.bytes.b[1] - ' ']; 308 | c.bytes = to_utf8(c.unicode); 309 | print(c); 310 | store(ed, c); 311 | return c.unicode; 312 | } 313 | 314 | Decoder *metatable[256] = { 315 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 316 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 317 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 318 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 319 | 320 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 321 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 322 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 323 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 324 | 325 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 326 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 327 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 328 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 329 | 330 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 331 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 332 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 333 | alpha, alpha, alpha, alpha, alpha, alpha, alpha, alpha, 334 | 335 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 336 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 337 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 338 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 339 | 340 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 341 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 342 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 343 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 344 | 345 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 346 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 347 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 348 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 349 | 350 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 351 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 352 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 353 | ignore, ignore, ignore, ignore, ignore, ignore, ignore, ignore, 354 | 355 | }; 356 | 357 | unsigned escape(editor *ed, character c){ 358 | //printbytes(c); 359 | switch(c.bytes.n){ 360 | case 1: ed->mode = 1 - ed->mode; break; 361 | case 2: ed->mode = 0; 362 | return metatable[c.bytes.b[1]](ed, c); 363 | case 3: ed->mode = 0; 364 | // TODO 365 | } 366 | return 0; 367 | } 368 | 369 | Decoder *controltable[32] = { 370 | //^@ ^A ^B ^C ^D ^E ^F ^G 371 | ignore, ignore, ignore, ignore, eot, ignore, ignore, bell, 372 | //^H ^I ^J ^K ^L ^M ^N ^O 373 | backspace, tab, linefeed, vtab, formfeed, carriage, shiftout, shiftin, 374 | //^P ^Q ^R ^S ^T ^U ^V ^W 375 | ignore, ignore, ignore, ignore, ignore, nak, ignore, ignore, 376 | //^X ^Y ^Z ^[ ^\ ^] ^^ ^_ 377 | ignore, ignore, ignore, escape, ignore, ignore, ignore, ignore, 378 | }; 379 | 380 | unsigned control(editor *ed, character c){ 381 | //printf("control character\n"); 382 | //c.bytes = (utfcp){ 2, '^', c.unicode + '@', 0, 0 }; 383 | return controltable[c.bytes.b[0]](ed, c); 384 | } 385 | 386 | unsigned ascii(editor *ed, character c){ 387 | if (ed->mode){ 388 | c.bytes.n = 2; 389 | c.bytes.b[1] = c.bytes.b[0]; 390 | c.bytes.b[0] = 27; 391 | return escape(ed, c); 392 | } 393 | print(c); 394 | store(ed, c); 395 | return c.unicode; 396 | } 397 | 398 | unsigned extended(editor *ed, character c){ 399 | return 0; 400 | } 401 | 402 | unsigned unicode2(editor *ed, character c){ 403 | print(c); 404 | store(ed, c); 405 | return c.unicode; 406 | } 407 | 408 | unsigned unicode3(editor *ed, character c){ 409 | print(c); 410 | store(ed, c); 411 | return c.unicode; 412 | } 413 | 414 | unsigned unicode4(editor *ed, character c){ 415 | print(c); 416 | store(ed, c); 417 | return c.unicode; 418 | } 419 | 420 | Decoder *chartable[256] = { 421 | control, control, control, control, control, control, control, control, 422 | control, control, control, control, control, control, control, control, 423 | control, control, control, control, control, control, control, control, 424 | control, control, control, control, control, control, control, control, 425 | 426 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 427 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 428 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 429 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 430 | 431 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 432 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 433 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 434 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 435 | 436 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 437 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 438 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 439 | ascii, ascii, ascii, ascii, ascii, ascii, ascii, ascii, 440 | 441 | extended, extended, extended, extended, extended, extended, extended, extended, 442 | extended, extended, extended, extended, extended, extended, extended, extended, 443 | extended, extended, extended, extended, extended, extended, extended, extended, 444 | extended, extended, extended, extended, extended, extended, extended, extended, 445 | 446 | extended, extended, extended, extended, extended, extended, extended, extended, 447 | extended, extended, extended, extended, extended, extended, extended, extended, 448 | extended, extended, extended, extended, extended, extended, extended, extended, 449 | extended, extended, extended, extended, extended, extended, extended, extended, 450 | 451 | unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, 452 | unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, 453 | unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, 454 | unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, unicode2, 455 | 456 | unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, 457 | unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, unicode3, 458 | 459 | unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, 460 | unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, unicode4, 461 | }; 462 | 463 | 464 | unsigned *read_line(char *prompt, unsigned **bufp, int *lenp){ 465 | if (prompt) fputs(prompt, stdout), fflush(stdout); 466 | if (!*bufp) *bufp = malloc( (sizeof**bufp) * (*lenp = 256)); 467 | unsigned *p = *bufp; 468 | 469 | character c; 470 | utfcp u; 471 | editor ed = { .bufp = p, .n = *lenp, .p = p, .mode = 0 }; 472 | unsigned x; 473 | do { 474 | c = read_character(); 475 | //printf("U%04x\n", c.unicode); 476 | //printf("%*s", u.n, u.b); 477 | x = chartable[c.bytes.b[0]](&ed, c); 478 | u = to_utf8(x); 479 | //printf("U%04x\n", x); 480 | //if (x) printf("%*s", u.n, u.b), fflush(stdout); 481 | //if (x) *p++ = x; 482 | } while (x != (unsigned)'\n' && x != (unsigned)EOF); 483 | *bufp = ed.bufp; 484 | *lenp = ed.n; 485 | p = ed.p; 486 | 487 | if (p[-1] == EOF) p[-1] = '\n'; 488 | if (p == (*bufp+1) && x == EOF){ 489 | return NULL; 490 | } 491 | return *bufp; 492 | } 493 | 494 | 495 | /////////////////////////////////////////////////////////////////////////////// 496 | // 497 | // main() 498 | // 499 | /////////////////////////////////////////////////////////////////////////////// 500 | 501 | int main(void){ 502 | init_terminal(); 503 | 504 | //printf("%u\n", (unsigned)'\n'); 505 | 506 | char *prompt = "> "; 507 | unsigned *buf = NULL; 508 | int len; 509 | while (read_line(prompt, &buf, &len)){ 510 | for (int i = 0; buf[i]!='\n'; ++i) 511 | printf("%04x ", buf[i]); 512 | puts(""); 513 | } 514 | 515 | return 0; 516 | } 517 | 518 | -------------------------------------------------------------------------------- /olmec/editor.c: -------------------------------------------------------------------------------- 1 | /* 2 | * The editor functions handle the *READ* part of the REPL. 3 | * It defines a large character-translation table to coordinate the 4 | * input-form/internal-rep/output-form for "normal" keyboards and an 5 | * "alternate" keyboard accessed with the alt key (also toggle-able 6 | * with ctrln). The alternate keyboard is patterned after the classic 7 | * APL keyboards I've seen. The ⎕a and ⎕k variables illustrate the 8 | * two keyboards, normal and ALT respectively. 9 | 10 | $ ./olmec 11 | ⎕a 12 | ~ ! @ # $ % ^ & * ( ) _ + 13 | ` 1 2 3 4 5 6 7 8 9 0 - = 14 | Q W E R T Y U I O P { } | 15 | q w e r t y u i o p [ ] \ 16 | A S D F G H J K L : " 17 | a s d f g h j k l ; ' 18 | Z X C V B N M < > ? 19 | z x c v b n m , . / 20 | 21 | ⎕k 22 | · ⌶ ⍫ ⍋ ⍒ ⌽ ⍉ ⊖ ⍟ ⍱ ⍲ ⌸ ⌹ 23 | ⋄ ¨ ¯ < ≤ = ≥ > ≠ ∨ ∧ × ÷ 24 | ¿ ⍹ ⍷ ℝ ⍭ ¥ ⌀ ⍸ ⍥ £ ⊣ ⊢ ⍙ 25 | ⍡ ⍵ ∈ ⍴ ⌾ ↑ ↓ ⍳ ○ ⋆ ← → ⍀ 26 | ⍶ ⌷ ⍄ ≡ ⍋ ⍒ ⍤ ⍃ ⍞ ⍂ ⌻ 27 | ⍺ ⌈ ⌊ ⍣ ∇ ∆ ∘ ⍢ ⎕ ⍁ ´ 28 | ⍧ ⌺ ⍝ ⍦ ⍎ ⍕ ⍔ « » ¶ 29 | ⊂ ⊃ ∩ ∪ ⊥ ⊤ ⍍ ⍪ ∵ ⌿ 30 | 31 | 32 | * 33 | * It sets up a specialtty() mode using termios settings and VT220 34 | * charset codes. The VT codes are largely a crutch until I better 35 | * understand how to interface Unicode more directly with Xterm. 36 | * In particular, diaeresis and macron and a few others do not 37 | * copy correctly with mouse selection. They display wrongly pasted 38 | * here in the source in vim. 39 | * 40 | */ 41 | #include 42 | #include 43 | #include 44 | #include 45 | #include 46 | #include 47 | #include 48 | #include 49 | #include 50 | 51 | /* Special ascii control-code macros 52 | */ 53 | #define ESC(x) "\x1b" #x 54 | #define ESCCHR '\x1b' 55 | #define CTL(x) (x-64) 56 | #define EOT 004 57 | #define DEL 127 58 | 59 | 60 | #include "common.h" 61 | #include "alpha.h" 62 | #include "editor.h" 63 | 64 | 65 | int inputtobase(int c, int mode){ 66 | int i; 67 | for (i=0;i<(sizeof alphatab/sizeof*alphatab);i++) 68 | if (c==*alphatab[i].input && mode==alphatab[i].ext) 69 | return alphatab[i].base; 70 | printf("input not in alpha: using MODE1\n"); 71 | return mode? MODE1(c): c; 72 | } 73 | 74 | char *basetooutput(int c){ 75 | int i; 76 | for (i=0;i<(sizeof alphatab/sizeof*alphatab);i++) 77 | if (c==alphatab[i].base) 78 | return alphatab[i].output; 79 | printf("output not in alpha: yielding empty string\n"); 80 | return ""; 81 | } 82 | 83 | void setcursor(enum cursor cursor){ 84 | printf(ESC([)"%d q",cursor); 85 | } 86 | 87 | struct termios tm; 88 | 89 | void restoretty(){ 90 | tcsetattr(0,TCSANOW,&tm); 91 | } 92 | 93 | void specialtty(){ 94 | #if 0 95 | #define DO(n,x) {int i=0,_n=(n);for(;i<_n;++i){x;}} 96 | fputs("\x1B*0\x1Bn",stdout); DO('~'-' ',printf("%c",' '+i))printf("\x1Bo\n"); 97 | fputs("\x1B*A\x1Bn",stdout); DO('~'-' ',printf("%c",' '+i))printf("\x1Bo\n"); 98 | fputs("\x1B*B\x1Bn",stdout); DO('~'-' ',printf("%c",' '+i))printf("\x1Bo\n"); 99 | fputc(CTL('N'),stdout); 100 | #endif 101 | 102 | // is the use of these causing my problems 103 | // outputing macron as \xc2\xaf or \xaf ? 104 | fputs(ESC()")B",stdout); // set G1 charset to B:usascii 105 | fputs(ESC(*0),stdout); // set G2 to 0:line drawing ESC(n) 106 | fputs(ESC(+A),stdout); // set G3 to A:"uk" accented ESC(o) (HI_MINUS) 107 | fputc(CTL('N'),stdout); // select G1 charset 108 | // ESC(n): select G2 109 | // ESC(o): select G3 110 | fflush(stdout); 111 | 112 | tcgetattr(0,&tm); 113 | 114 | struct termios tt=tm; 115 | tt.c_iflag |= IGNPAR; //ignore parity errors 116 | tt.c_iflag &= ~(IGNBRK | PARMRK | ISTRIP | ICRNL |INLCR |IGNCR 117 | | IXON | IXANY | IXOFF); //ignore special characters 118 | tt.c_lflag &= ~(ECHO | ECHOE | ECHOK | ECHONL 119 | | ICANON 120 | /*| ISIG*/ ); // non-canonical mode, no echo, no kill 121 | //tt.c_lflag &= ~IEXTEN; 122 | tt.c_cflag &= ~(CSIZE | PARENB); 123 | tt.c_cflag |= CS8; 124 | tt.c_oflag &= ~(/*OPOST |*/ ONLCR | OCRNL | ONOCR); // disable special output processing 125 | tt.c_oflag |= (/*ONOCR |*/ OPOST | ONLCR ); 126 | tt.c_cc[VMIN] = 3; // min chars to read 127 | tt.c_cc[VTIME] = 1; // timeout 128 | //cfmakeraw(&tt); 129 | if (tcsetattr(0,TCSANOW,&tt) == -1) 130 | perror("tcsetattr"); 131 | 132 | atexit(restoretty); 133 | } 134 | 135 | void beep(){ 136 | fputc(CTL('G'), stdout); 137 | fflush(stdout); 138 | } 139 | 140 | void tostartofline(){ 141 | //fputc(0x0D, stdout); 142 | fputc('\r', stdout); 143 | } 144 | 145 | void clearline(){ 146 | fputs(ESC([0J), stdout); 147 | //fputc(CTL('U'), stdout); 148 | //fflush(stdout); 149 | } 150 | 151 | void linefeed(){ 152 | fputc('\n', stdout); 153 | } 154 | 155 | int *get_line(char *prompt, int **bufref, int *len, int *expn){ 156 | int mode = 0; 157 | int tmpmode = 0; 158 | int *p; 159 | 160 | if (!*bufref) { 161 | *bufref = malloc((sizeof**bufref) * (*len=256)); 162 | p = *bufref; 163 | } else { 164 | for (p = *bufref; *p; ++p) 165 | ; 166 | } 167 | 168 | while(1){ 169 | int c; 170 | 171 | tostartofline(); 172 | clearline(); 173 | if (prompt) fputs(prompt,stdout); 174 | for (int *t=*bufref; t*len){ 180 | int *t = realloc(*bufref,(sizeof**bufref) * (*len*=2)); 181 | if (t) *bufref = t; 182 | else { *len/=2; return NULL; } 183 | } 184 | 185 | char key[3]; 186 | int n; 187 | n = -1; 188 | while(n==-1){ 189 | n = read(0, key, 3); 190 | c = key[0]; 191 | } 192 | 193 | //printf("%d\n", c); 194 | switch(c){ 195 | case EOF: 196 | case EOT: if (p==*bufref) goto err; 197 | break; 198 | case ESCCHR: 199 | switch(n){ 200 | case 1: // bare ESC key 201 | tmpmode = 1; 202 | break; 203 | case 2: 204 | c = key[1]; // ESC-$(c) 205 | switch(c){ 206 | default: 207 | tmpmode = 1; 208 | goto storechar; 209 | break; 210 | } 211 | case 3: 212 | c = key[2]; // 3-char ESC sequence 213 | //printf("%02x%c%c",key[0],key[1],key[2]); 214 | //fflush(stdout); 215 | switch(c){ 216 | case 'A': //up-arrow 217 | case 'B': //down-arrow 218 | case 'C': //right-arrow 219 | case 'D': //left-arrow 220 | ; 221 | } 222 | break; 223 | } 224 | break; 225 | case '\r': 226 | case '\n': 227 | tostartofline(); 228 | linefeed(); 229 | *p++ = c; 230 | goto breakwhile; 231 | case CTL('N'): 232 | beep(); 233 | mode = !mode; 234 | tmpmode = 0; 235 | break; 236 | case CTL('U'): 237 | /* 238 | while(p>*bufref){ 239 | fputs("\b \b", stdout); 240 | fflush(stdout); 241 | --p; 242 | } 243 | */ 244 | p = *bufref; 245 | tmpmode = 0; 246 | break; 247 | case '\b': 248 | case DEL: 249 | fputs("\b \b", stdout); 250 | fflush(stdout); 251 | if (p!=*bufref) --p; 252 | break; 253 | default: 254 | storechar: 255 | c = inputtobase(c,mode^tmpmode); 256 | *p++ = c; 257 | tmpmode = 0; 258 | //fputs(basetooutput(c), stdout); 259 | //fflush(stdout); 260 | break; 261 | } 262 | } 263 | breakwhile: 264 | *p++ = 0; 265 | *expn = p-*bufref; 266 | err: 267 | return p==*bufref?NULL:*bufref; 268 | } 269 | 270 | -------------------------------------------------------------------------------- /olmec/editor.h: -------------------------------------------------------------------------------- 1 | #include "common.h" 2 | /* the raw-mode editor */ 3 | 4 | int inputtobase(int c, int mode); 5 | char *basetooutput(int c); 6 | 7 | enum cursor {blockblink, blockblink_, block, underblink, under, barblink, bar}; 8 | void setcursor(enum cursor cursor); 9 | 10 | /* setup special raw terminal mode and save restore variable */ 11 | void specialtty(); 12 | 13 | /* use restore variable to reset terminal to normal mode */ 14 | void restoretty(); 15 | 16 | /* get input line as int array of internal codes */ 17 | int *get_line(char *prompt, int **bufref, int *buflen, int *expn); 18 | 19 | -------------------------------------------------------------------------------- /olmec/encoding.c: -------------------------------------------------------------------------------- 1 | /* Encoding 2 | * 3 | * this file defines the sub-typing of data atoms. 4 | * All data are packed into integer handles. The benefit for 5 | * array operations is all data atoms will have a uniform 6 | * size no matter what the content actually is. This replaces 7 | * the intptr_t hackery (ab)used in earlier versions 8 | * (not portable to 64bit build). 9 | * 10 | * the array data are always just straight 32bit integers. 11 | * but we treat as a 7bit tag and 24bit integer value. 12 | * An immediate integer value is indicated by a negative 13 | * sign-bit or all-zero tag. In essence, a 25bit sign/magnitude 14 | * rep with no -0. This also means that we're not really using 15 | * up all the available bits. Depending upon the final suite 16 | * of distinct types and the desired "word size", this arrangement 17 | * might be optimized further. 18 | * 19 | * Composite objects (boxed or reference objects) have 20 | * an associated pointer stored in an array associated 21 | * with the tag. Thus an array object can be enclosed 22 | * into a scalar (integer handle) with 23 | * 24 | * int x; 25 | * x = cache(ARRAY, array_new_dims(3,3)); //3x3 matrix 26 | * 27 | * To better convey the abstract use of this integer type, 28 | * we will make use of this typedef to designate such int-handles. 29 | * 30 | * commont.h: 31 | * typedef int object; 32 | * 33 | * the array data structure (which is implicitly a pointer 34 | * to its struct) can be retrived from the handle 35 | * with 36 | * 37 | * array a; 38 | * a = getptr(x); 39 | * 40 | * Most functions will need to check the types of their 41 | * arguments in order to determine how to proceed. 42 | * This can be accomplished with `gettag()`. 43 | * 44 | * switch(gettag(x)){ 45 | * case LITERAL: // handle atomic integer 46 | * break; 47 | * case ARRAY: { 48 | * array X = getptr(x); 49 | * } 50 | * } 51 | */ 52 | 53 | #include 54 | #include 55 | 56 | #include "common.h" 57 | #include "encoding.h" 58 | #include "array.h" 59 | 60 | int gettag(object d){ 61 | if (d<0) return 0; /* negatives are literals */ 62 | integer int32; 63 | int32.int32 = d; 64 | 65 | return int32.uint32 >> 24; 66 | } 67 | 68 | int getval(object d){ 69 | if (d<0) return d; 70 | integer int32; 71 | int32.int32 = d; 72 | return int32.uint32 & ((1U<<24)-1); 73 | } 74 | 75 | object newdata(int tag, int val){ 76 | if (tag==LITERAL && val<0) return val; 77 | integer int32; 78 | int32.uint32 = ((unsigned)tag << 24) | ((unsigned)val & ((1U<<24)-1)); 79 | int x = int32.int32; 80 | DEBUG(3,"newdata %x(%d %d)\n", x, tag, val); 81 | return x; 82 | } 83 | 84 | integer nulldata;// = { .data = { .tag = NULLOBJ, .val = 0 } }; 85 | object null /* = nulldata.int32 */; 86 | integer markdata;// = { .data = { .tag = MARKOBJ, .val = 0 } }; 87 | object mark /* = markdata.int32 */; 88 | object nil; 89 | object blank; 90 | 91 | void init_en(void){ 92 | nulldata.uint32 = newdata(NULLOBJ, 0); 93 | null = nulldata.int32; 94 | markdata.uint32 = newdata(MARKOBJ, 0); 95 | mark = markdata.int32; 96 | cache(LBRACOBJ, array_new_rank_dims(0)); 97 | blank = newdata(CHAR, ' '); 98 | } 99 | 100 | int addnewtocache(size_t *used, size_t *max, void ***data, void *ptr){ 101 | if (*used == *max){ 102 | *max = *max * 7 + 11; 103 | void *tmp = realloc(*data, *max * sizeof(void*)); 104 | if (!tmp) return null; 105 | *data = tmp; 106 | } 107 | int z = (*used)++; 108 | (*data)[z] = ptr; 109 | DEBUG(3,"addnew %d %p %p\n", z, ptr, (*data)[z]); 110 | return z; 111 | } 112 | 113 | 114 | struct memory_bank { 115 | size_t used, max; 116 | void **tab; 117 | } memory_bank[LAST_INDEXED_TYPE - FIRST_INDEXED_TYPE + 1]; 118 | 119 | object cache(int tag, void *ptr){ 120 | if (tag < FIRST_INDEXED_TYPE || tag > LAST_INDEXED_TYPE) 121 | return null; 122 | int idx = tag - FIRST_INDEXED_TYPE; 123 | return newdata(tag, 124 | addnewtocache(&memory_bank[idx].used, 125 | &memory_bank[idx].max, 126 | &memory_bank[idx].tab, 127 | ptr)); 128 | } 129 | 130 | void *getptr(object d){ 131 | if (d<0) return NULL; 132 | int tag = gettag(d); 133 | if (tag < FIRST_INDEXED_TYPE || tag > LAST_INDEXED_TYPE) 134 | return NULL; 135 | int idx = tag - FIRST_INDEXED_TYPE; 136 | return memory_bank[idx].tab[getval(d)]; 137 | } 138 | 139 | 140 | // fill returns a "blank" value for any type 141 | // and identity elements for verbs 142 | object getfill(object d){ 143 | switch(gettag(d)){ 144 | case PCHAR: 145 | switch(getval(d)){ 146 | case '+': 147 | return 0; 148 | case 0x00d7: // Times 149 | case 0x00f7: // Divided-By 150 | case '*': 151 | return 1; 152 | } /*fallthru*/ 153 | default: 154 | case LITERAL: 155 | return newdata(CHAR, 0x2300); //null 156 | return newdata(CHAR, 0x2316); //position 157 | return newdata(CHAR, 0x2218); //jot 158 | //return newdata(LITERAL, (1<<24)-1); 159 | case CHAR: return newdata(CHAR, ' '); 160 | } 161 | } 162 | 163 | -------------------------------------------------------------------------------- /olmec/encoding.h: -------------------------------------------------------------------------------- 1 | #ifndef ENCODING_H_ 2 | #define ENCODING_H_ 3 | #include "common.h" 4 | 5 | extern object null; 6 | extern object mark; 7 | extern object nil; 8 | extern object blank; 9 | 10 | void init_en(); 11 | 12 | int gettag(object d); 13 | int getval(object d); 14 | object newdata(int tag, int val); 15 | 16 | object cache(int tag, void *ptr); 17 | void *getptr(object d); 18 | object getfill(object d); 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /olmec/exec.h: -------------------------------------------------------------------------------- 1 | 2 | // predicate table contains predicate functions 3 | // and associated enum values 4 | #define PREDICATES_FOREACH(_) \ 5 | _( ANY = 1, qany, 1 ) \ 6 | _( VAR = 2, qprog, gettag(x)==PROG \ 7 | || (gettag(x)==PCHAR && getval(x)!=0x2190 /*leftarrow*/ ) ) \ 8 | _( NOUN = 4, qnoun, gettag(x)==LITERAL \ 9 | || gettag(x)==NUMBER \ 10 | || gettag(x)==CHAR \ 11 | || gettag(x)==ARRAY ) \ 12 | _( NIL = 8, qnil, (gettag(x)==VERB && ((verb)getptr(x))->nilad) ) \ 13 | _( MON = 16, qmon, (gettag(x)==VERB && ((verb)getptr(x))->monad) \ 14 | || (gettag(x)==XVERB && ((xverb)getptr(x))->verb->monad) ) \ 15 | _( DYA = 32, qdya, (gettag(x)==VERB && ((verb)getptr(x))->dyad) \ 16 | || (gettag(x)==XVERB && ((xverb)getptr(x))->verb->dyad) ) \ 17 | _( VRB = 64, qverb, qmon(x) || qdya(x) ) \ 18 | _( DEX = 128, qdex, 0 ) /*dextri-monadic verb*/\ 19 | _( ADV = 256, qadv, (gettag(x)==ADVERB && ((verb)getptr(x))->monad) \ 20 | || (gettag(x)==XVERB && ((xverb)getptr(x))->adverb->monad) ) \ 21 | _( LEV = 512, qlev, 0 ) /*sinister adverb*/\ 22 | _( CONJ = 1024, qconj, (gettag(x)==ADVERB && ((verb)getptr(x))->dyad) \ 23 | || (gettag(x)==XVERB && ((xverb)getptr(x))->adverb->dyad) ) \ 24 | _( MARK = 2048, qmark, gettag(x)==MARKOBJ ) \ 25 | _( ASSN = 4096, qassn, gettag(x)==PCHAR && getval(x) == 0x2190 ) \ 26 | _( LPAR = 8192, qlpar, gettag(x)==LPAROBJ ) \ 27 | _( RPAR = 16384, qrpar, gettag(x)==RPAROBJ ) \ 28 | _( LBRAC = 32768, qlbrac, gettag(x)==LBRACOBJ ) \ 29 | _( RBRAC = 65536, qrbrac, gettag(x)==RBRACOBJ ) \ 30 | _( NUL = 131072, qnull, gettag(x)==NULLOBJ ) \ 31 | _( SEMI = 262144, qsemi, gettag(x)==SEMIOBJ ) \ 32 | _( COLON = 524288, qcolon, gettag(x)==PCHAR && getval(x)==':') \ 33 | _( LAB =1048576, qlabel, gettag(x)==LABEL ) \ 34 | /**/ 35 | 36 | // declare predicate functions 37 | #define DECLARE_PREDICATE_FUNCTION(enum_def,fname,...) int fname(object); 38 | PREDICATES_FOREACH(DECLARE_PREDICATE_FUNCTION) 39 | 40 | // execute expression or block array object 41 | object execute(object exp, symtab env, int *plast_was_assn); 42 | 43 | // execute an expression e with environment st 44 | object execute_expression(array expr, symtab env, int *plast_was_assn); 45 | 46 | -------------------------------------------------------------------------------- /olmec/exec_private.h: -------------------------------------------------------------------------------- 1 | 2 | /* predicate functions are instantiated according to the 3 | * PREDICATES_FOREACH X-macro. 4 | * the q[] function array is used by classify to apply all 5 | * predicate functions yielding a sum of all applicable codes 6 | * defined in the table. Specific qualities or combinations 7 | * may then be determined easily by masking. 8 | */ 9 | #define DEFINE_PREDICATE_FUNCTION(enum_def,fname,...) \ 10 | int fname(object x){ (void)x; return __VA_ARGS__; } 11 | PREDICATES_FOREACH(DEFINE_PREDICATE_FUNCTION) 12 | #undef DEFINE_PREDICATE_FUNCTION 13 | 14 | static 15 | int (*q[])(object) = { 16 | #define PREDICATE_FUNCTION_NAME(enum_def,fname,...) \ 17 | fname, 18 | PREDICATES_FOREACH(PREDICATE_FUNCTION_NAME) 19 | #undef PREDICATE_FUNCTION_NAME 20 | }; 21 | 22 | // declare predicate enums and composed patterns 23 | enum predicate { 24 | #define PREDICATE_ENUMERATION(enum_def,...) \ 25 | enum_def, 26 | PREDICATES_FOREACH(PREDICATE_ENUMERATION) 27 | #undef PREDICATE_ENUMERATION 28 | EDGE = MARK+ASSN+LPAR + LBRAC, 29 | AVN = VRB+NOUN+ADV 30 | }; 31 | 32 | /* encode predicate applications into a binary number 33 | which can be compared to a pattern with a mask */ 34 | static 35 | inline int classify(object x){ 36 | int i,v,r; 37 | for (i=0, v=1, r=0; iitems[3] items[2] items[1] items[0] */ \ 56 | /* items[start..finish] => func(items[start..finish]) */\ 57 | /* func start finish hack */\ 58 | _(L0, EDGE, MON, NOUN, ANY, monadic, 2, 1, 0) \ 59 | _(L1, EDGE+AVN, VRB, MON, NOUN, monadic, 1, 0, 0) \ 60 | _(L2, ANY, NOUN, DEX, ANY, monadic, 1, 2, 0) \ 61 | _(L3, EDGE+AVN, NOUN, DYA, NOUN, dyadic, 2, 0, 0) \ 62 | _(L4, EDGE+AVN, NOUN+VRB, ADV, ANY, adv, 2, 1, 0) \ 63 | _(L5, ANY, LEV, NOUN+VRB, ANY, adv, 1, 2, 0) \ 64 | _(L6, EDGE+AVN, NOUN+VRB, CONJ, NOUN+VRB, conj_, 2, 0, 0) \ 65 | _(L7, ANY, NOUN, DYA, RPAR+NUL+MARK, lcurry, 2, 1, 0) \ 66 | _(L8, VAR, ASSN, AVN, ANY, spec, 3, 1, 0) \ 67 | _(L9, NOUN, ASSN, NOUN, ANY, move, 3, 1, 0) \ 68 | _(L10,LPAR, ANY, RPAR, ANY, punc, 3, 1, 0) \ 69 | _(L11,MARK, ANY, RPAR, ANY, punc, 1, 2, \ 70 | stack_push(left,stack_pop(right)) ) \ 71 | _(L12,ANY, LPAR, ANY, MARK, punc, 2, 1, 0) \ 72 | _(L13,LBRAC, SEMI, ANY, ANY, brasemi, 3, 2, 0) \ 73 | _(L14,LBRAC, NOUN, SEMI, ANY, branoun, 3, 1, 0) \ 74 | _(L15,LBRAC, NOUN, RBRAC, ANY, bracket, 3, 2, 0) \ 75 | _(L16,LBRAC, LBRAC, RBRAC, ANY, bracidx, 3, 1, 0) \ 76 | _(L17,VRB+ADV, LBRAC, RBRAC, ANY, funcidx, 3, 1, 0) \ 77 | _(L18,NOUN, LBRAC, RBRAC, ANY, nounidx, 3, 1, 0) \ 78 | /**/ 79 | 80 | enum { // generate labels to coordinate table and execution 81 | #define PRODUCTION_LABEL(label, ...) label, 82 | PARSE_PRODUCTIONS_FOREACH(PRODUCTION_LABEL) 83 | #undef PRODUCTION_LABEL 84 | }; 85 | 86 | static 87 | struct parsetab { int c[4]; } ptab[] = { 88 | #define PRODUCTION_PATTERNS(label, pat1, pat2, pat3, pat4, ...) \ 89 | {{pat1, pat2, pat3, pat4}}, 90 | PARSE_PRODUCTIONS_FOREACH(PRODUCTION_PATTERNS) 91 | #undef PRODUCTION_PATTERNS 92 | }; 93 | 94 | static 95 | int min(int x, int y){ 96 | return x0 ? 1 : -1; /*orientation of stack->args mapping*/\ 103 | int n = 1+abs(f-s); /*number of elements to pass (and remove)*/\ 104 | int minfs = min(f,s); /*location to store result*/\ 105 | int excess = 4 - n - minfs; /*number of elements to shift down after*/\ 106 | DEBUG(3, "s=%d f=%d dir=%d, n=%d, minfs=%d, excess=%d\n", \ 107 | s, f, dir, n, minfs, excess); \ 108 | items[minfs] = \ 109 | datum_to_stack_element( \ 110 | func(n>=1? items[s+0*dir].datum: 0, \ 111 | n>=2? items[s+1*dir].datum: 0, \ 112 | n>=3? items[s+2*dir].datum: 0, \ 113 | n>=4? items[s+3*dir].datum: 0, \ 114 | env) \ 115 | ); \ 116 | if (is_label(items[minfs])) \ 117 | return branchout(left, right, items[minfs].datum); \ 118 | minfs -= is_mark(items[minfs]); /*suppress "noresult" indicater*/\ 119 | for (int i=0; ielements[0]); 173 | return r->next = 0, r->limit = n, r; 174 | } 175 | 176 | static 177 | void stack_release (stack s){ 178 | free(s); 179 | } 180 | 181 | static 182 | unsigned stack_capacity (stack s){ 183 | return s->limit; 184 | } 185 | 186 | static 187 | int stack_is_empty (stack s){ 188 | return s->next == 0; 189 | } 190 | 191 | static 192 | void stack_push (stack s, stack_element e){ 193 | s->elements[ s->next++ ] = e; 194 | } 195 | 196 | static 197 | stack_element datum_to_stack_element (int d){ 198 | return (stack_element){ d, classify(d) }; 199 | } 200 | 201 | static 202 | void stack_push_datum (stack s, int d){ 203 | stack_push(s, datum_to_stack_element(d)); 204 | } 205 | 206 | static 207 | stack_element stack_pop (stack s){ 208 | return s->elements[ --s->next ]; 209 | } 210 | 211 | static 212 | unsigned stack_element_count (stack s){ 213 | return s->next; 214 | } 215 | 216 | static 217 | void stack_prune (stack s, unsigned n){ 218 | s->next -= n; 219 | } 220 | 221 | static 222 | void stack_reclaim (stack s, unsigned n){ 223 | s->next += n; 224 | } 225 | 226 | static 227 | stack_element *stack_top_elements_address (stack s, unsigned n){ 228 | return s->elements + s->next - n; 229 | } 230 | 231 | object branchout(stack left, stack right, object label); 232 | static int is_del_func(array expr); 233 | static int is_func_def(array expr); 234 | static int is_cond_exp(array expr); 235 | 236 | static int is_label(stack_element x); 237 | static int is_pronoun(stack_element x); 238 | static int is_assn(stack_element x); 239 | static int is_mark(stack_element x); 240 | static int is_nilad(stack_element x); 241 | static size_t sum_symbol_lengths(array e, int n); 242 | static int parse_and_lookup_name(stack left, stack right, stack_element *x, symtab env); 243 | static stack new_left_stack_for (array expr); 244 | static int matches_ptab_pattern (stack_element items[4], int i); 245 | static int penultimate_prereleased_value (stack s); 246 | 247 | -------------------------------------------------------------------------------- /olmec/execs.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/luser-dr00g/inca/d369b9827158a6bb7caca9d2b85bef23e0cdf3fe/olmec/execs.tgz -------------------------------------------------------------------------------- /olmec/io.c: -------------------------------------------------------------------------------- 1 | //cf. https://codereview.stackexchange.com/questions/98838/utf-8-encoding-decoding 2 | //cf. http://www.ietf.org/rfc/rfc3629.txt p.3 3 | #include 4 | #include 5 | #include 6 | #include // log2 7 | //#include // ilog2 8 | 9 | #include "io.h" 10 | 11 | /* number of leading zeros of byte-sized value */ 12 | static int leading0s(uint_least32_t x){ return 7 - (x? floor(log2(x)): -1); } 13 | 14 | /* number of leading ones of byte-sized value */ 15 | #define leading1s(x) leading0s(0xFF^(x)) 16 | 17 | /*generate unsigned long mask of x ones in the least-significant position */ 18 | #define lomask(x) ((1UL<<(x))-1) 19 | 20 | /* generate byte mask of x ones in the most-significant position */ 21 | #define himask(x) (0xFF^lomask(8-(x))) 22 | 23 | uint32_t expand_shortcut(unsigned char b){ 24 | return REPLACEMENT; 25 | } 26 | 27 | uint32_t to_ucs4(utfcp c){ 28 | int prefix = leading1s(c.b[0]); 29 | int n = prefix? prefix: 1; 30 | uint32_t u; 31 | //printf("prefix:%d\n",n); 32 | //if (n != c.n) 33 | switch(prefix){ 34 | case 0: u = c.b[0]; break; 35 | case 1: return u = expand_shortcut(c.b[0]); 36 | case 2: u = c.b[0] & 0x1f; break; 37 | case 3: u = c.b[0] & 0x0f; break; 38 | case 4: u = c.b[0] & 0x07; break; 39 | } 40 | //printf("%04x\n", u); 41 | for(int i=1; i>6), 56 | 0x80|(u&0x3f)}; 57 | if (u<0x10000) return (utfcp){3,0xE0|(u>>12), 58 | 0x80|((u>>6)&0x3f),0x80|(u&0x3f)}; 59 | if (u<0x110000) return (utfcp){4,0xF0|(u>>18), 60 | 0x80|((u>>12)&0x3f),0x80|((u>>6)&0x3f),0x80|(u&0x3f)}; 61 | //(else) error RANGE 62 | return (utfcp){0,0}; 63 | } 64 | 65 | uint32_t *ucs4(char *str, int n, int *an, enum errinfo *errinfo){ 66 | unsigned char *p=str; 67 | int32_t *u,*buf; 68 | uint_least32_t x; 69 | int prefix; 70 | int i,j; 71 | enum errinfo error = no_error; 72 | 73 | buf=u=malloc(n*sizeof*u); 74 | if (!buf) { 75 | error |= buffer_alloc_fail; 76 | } 77 | else { 78 | for (i=0; i>6) & lomask(5)); 134 | *p++=himask(1)| ((x) & lomask(6)); 135 | } 136 | else if (x <= lomask(16)) { 137 | *p++=himask(3)| ((x>>12) & lomask(4)); 138 | *p++=himask(1)| ((x>>6) & lomask(6)); 139 | *p++=himask(1)| ((x) & lomask(6)); 140 | } 141 | else if (x <= 0x10FFFF) { 142 | *p++=himask(4)| ((x>>18) & lomask(3)); 143 | *p++=himask(1)| ((x>>12) & lomask(6)); 144 | *p++=himask(1)| ((x>>6) & lomask(6)); 145 | *p++=himask(1)| ((x) & lomask(6)); 146 | } 147 | else { 148 | error |= code_point_out_of_range; 149 | } 150 | } 151 | *p++=0; 152 | } 153 | 154 | if (an) *an = p-buf; 155 | if (errinfo) *errinfo = error; 156 | return buf; 157 | } 158 | 159 | #ifdef TESTMODULE 160 | #include "stdlib.h" 161 | #include "string.h" 162 | #include "minunit.h" 163 | int tests_run = 0; 164 | 165 | static char *test_leading0s(){ 166 | //int i;for(i=0;i<256;i++)printf("%d <%x>,nlz %d,nlo %d\n",i,i,leading0s(i),leading0s(i^0xFF)); 167 | test_case(leading0s(0)!=8); 168 | test_case(leading0s(1)!=7); 169 | test_case(leading0s(2)!=6); 170 | test_case(leading0s(4)!=5); 171 | test_case(leading0s(8)!=4); 172 | test_case(leading0s(16)!=3); 173 | test_case(leading0s(32)!=2); 174 | test_case(leading0s(64)!=1); 175 | test_case(leading0s(128)!=0); 176 | //test_case(2!="baloney"); 177 | return 0; 178 | } 179 | 180 | #define UNI_EQUS(_) \ 181 | /* str, ints, size */ \ 182 | _("abc", ((int[]){97,98,99}), 3) \ 183 | /*enddef UNI_EQUS */ 184 | 185 | 186 | static char *test_utf8(){ 187 | #define UTF_TEST(str,ints,size) \ 188 | test_case(strcmp(str, \ 189 | utf8(ints,size,NULL,NULL))); 190 | /* test_case(strcmp("abc", 191 | utf8((int[]){97,98,99},3,NULL,NULL))); */ 192 | UNI_EQUS(UTF_TEST) 193 | return 0; 194 | } 195 | 196 | 197 | static char *test_ucs4(){ 198 | #define UCS_TEST(str,ints,size) \ 199 | test_case(memcmp(ints, \ 200 | ucs4(str,size,NULL,NULL), \ 201 | size*sizeof(int))); 202 | /* test_case(memcmp((int[]){97,98,99}, 203 | ucs4("abc",3,NULL,NULL), 204 | 3*sizeof(int))); */ 205 | UNI_EQUS(UCS_TEST) 206 | return 0; 207 | } 208 | 209 | 210 | 211 | static char *test_transit(){ 212 | #define UTF_UCS_TEST(str,ints,size) \ 213 | test_case(strcmp(str, \ 214 | utf8(ucs4(str,size,NULL,NULL),size,NULL,NULL))); 215 | /* test_case(strcmp("abc", 216 | utf8(ucs4("abc",3,NULL,NULL),3,NULL,NULL))); */ 217 | UNI_EQUS(UTF_UCS_TEST) 218 | 219 | #define UCS_UTF_TEST(str,ints,size) \ 220 | test_case(memcmp(ints, \ 221 | ucs4(utf8(ints,size,NULL,NULL),size,NULL,NULL), \ 222 | size*sizeof(int))); 223 | /* test_case(memcmp((int[]){97,98,99}, 224 | ucs4(utf8((int[]){97,98,99},3,NULL,NULL),3,NULL,NULL), 225 | 3*sizeof(int))); */ 226 | UNI_EQUS(UCS_UTF_TEST) 227 | return 0; 228 | } 229 | 230 | 231 | static char *all_tests(){ 232 | mu_run_test(test_leading0s); 233 | mu_run_test(test_utf8); 234 | mu_run_test(test_ucs4); 235 | mu_run_test(test_transit); 236 | return 0; 237 | } 238 | 239 | int main() { 240 | 241 | char *result=all_tests(); 242 | if (result != 0) { 243 | printf("%s\n",result); 244 | } else { 245 | printf("ALL TESTS PASSED\n"); 246 | } 247 | printf("Tests run: %d\n", tests_run); 248 | return result != 0; 249 | 250 | } 251 | 252 | #endif //defined TESTMODULE 253 | -------------------------------------------------------------------------------- /olmec/io.h: -------------------------------------------------------------------------------- 1 | /* Unicode format conversions */ 2 | 3 | /* 4 | <-------- adapters ("apps-"hungarian naming) 5 | utf8 utf8(ucs4...) 6 | ucs4 ucs4(utf8...) 7 | */ 8 | 9 | enum errinfo { 10 | no_error = 0, 11 | invalid_encoding = 1, 12 | invalid_extended_encoding = 2, 13 | buffer_alloc_fail = 4, 14 | bad_following_character = 8, 15 | over_length_encoding = 16, 16 | code_point_out_of_range = 32, 17 | }; 18 | 19 | typedef struct { 20 | int n; 21 | unsigned char b[4]; 22 | } utfcp; 23 | uint32_t to_ucs4(utfcp c); 24 | utfcp to_utf8(uint32_t u); 25 | uint32_t *ucs4(char *str, int n, int *an, enum errinfo *errinfo); 26 | char *utf8(uint32_t *ar, int n, int *an, enum errinfo *errinfo); 27 | 28 | #define REPLACEMENT 0xFFFD 29 | 30 | -------------------------------------------------------------------------------- /olmec/io_test.c: -------------------------------------------------------------------------------- 1 | #define TESTMODULE 2 | #include "io.c" 3 | -------------------------------------------------------------------------------- /olmec/lex.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Word Formation (scanning) 3 | * 4 | * As shown in the encoding module, 5 | * characters are stored in 24bits of a 32bit int, so Unicode 6 | * characters are referred-to by their UCS4 code. 7 | * 8 | * This decision affects the scanner code in that it must deal 9 | * with "int-strings" although the contents are expected to 10 | * mostly be restricted to the ascii domain. One special char 11 | * recognized by the scanner is the left-arrow char ← which is 12 | * used for assignment of values to variables. 13 | * 14 | * The scanner is also unusual in that it treats most characters 15 | * as identifier characters, even the punctuation chars which 16 | * designate functions. These identifiers are resolved later 17 | * during symbol-lookup using prefix-matching to further scan 18 | * and parse the identifiers. For the current purpose of these 19 | * functions, it is sufficient to distinguish numbers from non- 20 | * numbers and to ensure that certain special characters like 21 | * the left-arrow and the parens are encoded as single tokens 22 | * and not parts of identifiers. 23 | * 24 | * So it's a state-machine that runs through each character 25 | * of the int-string. The character is classified into a 26 | * character-class which determines the column of the big table. 27 | * The current state (initially 0 or "ini") determines 28 | * the row of the big table. The value in the table encodes 29 | * a new state (the 10s value) and an action (the 1s value). 30 | * The action code adjusts the start-of-token position in 31 | * the strings and can trigger the generation of a new token. 32 | * The new token is packed into an integer handle and simply 33 | * appended to the array structure to be returned. 34 | * 35 | * The state-machine itself is "programmed" by the table and 36 | * enum definitions in wd_private.h. 37 | * 38 | */ 39 | 40 | #include 41 | #include 42 | #include 43 | 44 | #include "array.h" // array type 45 | #include "encoding.h" // atomic encoding 46 | #include "symtab.h" 47 | #include "number.h" 48 | 49 | #include "lex.h" 50 | 51 | int quadneg; // hi-minus v. minus semantics. 52 | // the value from the symbol table is 53 | // cached here at the start of scan_expression 54 | 55 | #include "lex_private.h" 56 | 57 | object scan_expression(array expr, symtab env){ 58 | int *s = expr->data; 59 | int n = expr->dims[0]; 60 | int tag = EXPR; 61 | 62 | array result = array_new_dims(n+1); 63 | array resultrow = result; 64 | int arrayisvector = 1; 65 | token *p = resultrow->data, *p1 = p+1; 66 | 67 | state ss, st; /* last state, current state */ 68 | state_and_action_code cc = 0; 69 | int i,j; 70 | 71 | check_quadneg(env); 72 | for (i=j=0, ss=st=0; i < n; i++, ss=st, st=state_from(cc)){ 73 | cc = wdtab[st][ character_class(s[i]) ]; 74 | DEBUG(2,"-%d-\n",cc); 75 | 76 | switch (action_from(cc)){ 77 | case 0: /* do nothing */ 78 | break; 79 | 80 | case 1: *p++ = newobj(s+j, i-j, st*10); 81 | j=i; 82 | break; 83 | 84 | case 2: j=i; 85 | break; 86 | 87 | case 3: *p++ = newobj(s+j, i-1-j, ss*10); 88 | j=i-1; 89 | break; 90 | 91 | case 4: /* eol */ 92 | //if ((st*10)!=ini) 93 | *p++ = newobj(s+j, i-j, st*10); 94 | j=i; 95 | resultrow->dims[0] = p - resultrow->data; // set length 96 | DEBUG(2, "eol\n"); 97 | if (arrayisvector){ 98 | if (j==n-2) break; 99 | arrayisvector = 0; 100 | tag = BLOCK; 101 | result = array_new_dims(3); 102 | *elem(result,0) = null; 103 | *elem(result,1) = cache(EXPR, resultrow); 104 | *elem(result,2) = cache(EXPR, resultrow = array_new_dims(n-j)); 105 | p = resultrow->data, p1 = p+1; 106 | } else { 107 | array newresult = array_new_dims(result->dims[0]+1); 108 | memcpy(newresult->data,result->data,result->dims[0]*sizeof(int)); 109 | *elem(newresult,result->dims[0]) = 110 | cache(EXPR, resultrow = array_new_dims(n-j)); 111 | //free(result); 112 | result = newresult; 113 | p = resultrow->data, p1 = p+1; 114 | } 115 | break; 116 | } 117 | 118 | if (p > p1) p=collapse_adjacent_numbers_if_needed(p); 119 | } 120 | 121 | resultrow->dims[0] = p - resultrow->data; // set actual encoded length 122 | if (!arrayisvector){ --result->dims[0]; } 123 | return cache(tag, result); 124 | } 125 | 126 | void check_quadneg(symtab st){ 127 | quadneg = symbol_value(st, newdata(PCHAR, 0x2395), newdata(PCHAR, '-')); 128 | if (gettag(quadneg)==ARRAY) 129 | quadneg = ((array)getptr(quadneg))->data[0]; 130 | DEBUG(2,"quadneg=%08x(%d,%d)\n",quadneg, gettag(quadneg), getval(quadneg)); 131 | } 132 | 133 | token *collapse_adjacent_numbers_if_needed(token *p){ 134 | if (gettag(p[-2])==ARRAY && gettag(p[-1])==ARRAY){ 135 | array p2 = getptr(p[-2]); 136 | array p1 = getptr(p[-1]); 137 | if (((p2->rank == 0 && p1->rank == 0) 138 | && (gettag(p2->data[0])==LITERAL 139 | && gettag(p1->data[0])==LITERAL)) 140 | || ((p2->rank == 1 && p1->rank == 0) 141 | && (gettag(p2->data[p2->dims[0]-1])==LITERAL 142 | && gettag(p1->data[0])==LITERAL))){ 143 | --p; 144 | p[-1] = cache(ARRAY,cat(p2, p1)); 145 | } 146 | } 147 | return p; 148 | } 149 | 150 | 151 | token new_numeric(int *s, int n){ 152 | DEBUG(2,"num:%d\n", n); 153 | char buf[n+1]; 154 | for (int i=0; i=(int32_t)0x00ffffffu || ll<=(int32_t)0xff000000u){ 166 | t = cache(NUMBER, new_number_z(buf)); 167 | } else { 168 | t = newdata(LITERAL, ll); 169 | } 170 | t = cache(ARRAY, scalar(t)); 171 | 172 | return t; 173 | } 174 | 175 | token new_string(int *s, int n){ 176 | DEBUG(2,"str:%d\n", n); 177 | //if (n==3){ return newdata(CHAR, s[1]); } 178 | array t=array_new_dims(n); 179 | int i,j,q; 180 | //for (int i=0; idims[0]=j; 190 | return cache(ARRAY, t); 191 | } 192 | 193 | token new_executable(int *s, int n){ 194 | DEBUG(2,"prog:%d\n", n); 195 | if (n==1){ 196 | if (*s == '(') return newdata(LPAROBJ, 0); 197 | if (*s == ')') return newdata(RPAROBJ, 0); 198 | if (*s == '[') return newdata(LBRACOBJ, 0); 199 | if (*s == ']') return newdata(RBRACOBJ, 0); 200 | if (*s == ';') return newdata(SEMIOBJ, 0); 201 | return newdata(PCHAR, *s); 202 | } else { 203 | array t=array_new_dims(n); 204 | for (int i=0; i 2 | 3 | typedef int token; 4 | typedef int state; 5 | typedef int state_and_action_code; 6 | #define state_from(s_a_a_c) ((s_a_a_c)/10) 7 | #define action_from(s_a_a_c) ((s_a_a_c)%10) 8 | 9 | /* 10 | * The transition table and state set 11 | * 12 | * Each state embodies a certain amount of "knowledge" 13 | * about what sort of token has been encountered. 14 | * The dot character '.' causes a great deal of trouble 15 | * since it is heavily overloaded. If the dot has a digit 16 | * on either or both sides, then it is considered a decimal 17 | * point separating the integer and fractional parts of a 18 | * floating-point number. 19 | * Otherwise, the dot is considered part of an identifier. 20 | * 21 | * Note, the state enum codes are 10* the corresponding table index. 22 | */ 23 | enum state { 24 | ini=0, //indeterminate 25 | min=10, //initial minus - 26 | dot=20, //initial dot . 27 | num=30, //integer 0 28 | dit=40, //medial dot 0. 29 | fra=50, //fraction 0.0 30 | str=60, //initial quote ' '' 31 | quo=70, //end or escape quote 'aaaa' 32 | oth=80, //identifier or other symbol a+ 33 | dut=90, //trailing dot +. 34 | tra=100, //trailing minus q- 35 | sng=110, //copula or other self-delimiting symbol () 36 | }; 37 | 38 | #define NUM_CLASSES \ 39 | sizeof((unsigned char[]) \ 40 | { 0, '-', '0', '.', '\'', '(', '?', ' ', 0x2190, '\r'}) 41 | state_and_action_code wdtab[][NUM_CLASSES] = { 42 | /* state*/ 43 | /* | *//*character class*/ 44 | /* V *//*none minus 0-9 . ' () oth sp <- \r */ 45 | /* 0 */{ oth+2, min+2, num+2, dot+2, str+2, sng+2, sng+2, ini+0, sng+2, ini+4 }, 46 | /* 10*/{ oth+0, min+1, num+0, dot+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 47 | /* 20*/{ oth+0, min+1, fra+0, oth+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 48 | /* 30*/{ oth+1, min+1, num+0, dit+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 49 | /* 40*/{ oth+0, min+1, num+0, dut+1, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 50 | /* 50*/{ oth+1, min+1, fra+0, dot+1, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 51 | /* 60*/{ str+0, str+0, str+0, str+0, quo+0, str+0, str+0, str+0, str+0, ini+4 }, 52 | /* 70*/{ oth+1, min+1, num+1, dot+1, str+0, sng+1, sng+1, ini+1, sng+1, ini+4 }, 53 | /* 80*/{ oth+0, tra+0, num+1, dut+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 54 | /* 90*/{ oth+0, tra+0, num+3, dut+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 55 | /*100*/{ oth+0, tra+0, num+3, dut+0, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 56 | /*110*/{ oth+1, min+1, num+1, dot+1, str+1, sng+1, sng+1, ini+1, sng+1, ini+4 }, 57 | }; 58 | 59 | static unsigned char cctab[128] = { 60 | ['0']=2, ['1']=2, ['2']=2, ['3']=2, ['4']=2, 61 | ['5']=2, ['6']=2, ['7']=2, ['8']=2, ['9']=2, 62 | ['.']=3, 63 | ['\'']=4, 64 | ['(']=5, [')']=5, 65 | ['[']=6, [']']=6, [';']=6, [':']=6, 66 | [' ']=7, ['\t']=7, 67 | [0x0D]=9, 68 | }; 69 | 70 | static inline unsigned char qminus(int ch){ 71 | return ch == (quadneg? '-': 0x00af); 72 | } 73 | 74 | static inline unsigned char character_class(int ch){ 75 | return 76 | qminus(ch)? 1: 77 | ch 2 | #define _BSD_SOURCE 3 | #include 4 | #include 5 | 6 | #include "common.h" 7 | #include "array.h" 8 | #include "editor.h" 9 | #include "encoding.h" 10 | #include "io.h" 11 | #include "symtab.h" 12 | #include "exec.h" 13 | #include "lex.h" 14 | #include "verbs.h" 15 | #include "adverbs.h" 16 | #include "xverb.h" 17 | #include "print.h" 18 | #include "number.h" 19 | 20 | // the global symbol table 21 | symtab env; 22 | 23 | // quad-neg variable controls minus/hi-minus semantics in 24 | // the lexical analysis 25 | void init_quad_neg(symtab st){ 26 | define_symbol(st, newdata(PCHAR, 0x2395),newdata(PCHAR, '-'), 0); 27 | } 28 | 29 | // define quad-k variable illustrating alt-keybaord layout 30 | // type quad with alt-l 31 | void init_quad_k(symtab st){ 32 | //alt-keyboard 33 | // 34 | //-> iterate over string 35 | char *rows[] = { 36 | "~!@#$%^&*()_+", 37 | "`1234567890-=", 38 | "QWERTYUIOP{}|", 39 | "qwertyuiop[]\\", 40 | "ASDFGHJKL:\"", 41 | "asdfghjkl;'", 42 | "ZXCVBNM<>?", 43 | "zxcvbnm,./", 44 | }; 45 | array qk = array_new_dims(8,13); 46 | for (int i=0,j; i<8; ++i){ 47 | for (j=0; j<13; ++j){ 48 | if (!rows[i][j]) break; 49 | *elem(qk,i,j) = newdata(PCHAR, inputtobase(rows[i][j],1)); 50 | } 51 | for (; j<13; ++j){ 52 | *elem(qk,i,j) = newdata(PCHAR, inputtobase(' ',0)); 53 | } 54 | } 55 | define_symbol(st,newdata(PCHAR, 0x2395),newdata(PCHAR, 'k'), cache(ARRAY, qk)); 56 | 57 | 58 | //normal keyboard 59 | array qa = array_new_dims(8,13); 60 | for (int i=0,j; i<8; ++i){ 61 | for (j=0; j<13; ++j){ 62 | if (!rows[i][j]) break; 63 | *elem(qa, i, j) = newdata(PCHAR, inputtobase(rows[i][j],0)); 64 | } 65 | for (; j<13; ++j){ 66 | *elem(qa, i, j) = newdata(PCHAR, inputtobase(' ',0)); 67 | } 68 | } 69 | define_symbol(st,newdata(PCHAR, 0x2395),newdata(PCHAR, 'a'), cache(ARRAY, qa)); 70 | } 71 | 72 | int mainloop(){ 73 | static int *buf = NULL; 74 | static int buflen; 75 | int expn; 76 | char *prompt = " "; 77 | int last_was_assn; 78 | 79 | while((buf?buf[0]=0:0), get_line(prompt, &buf, &buflen, &expn)){ 80 | 81 | IFDEBUG(2, 82 | for (int i=0;idata,buf,expn*sizeof(int)); 89 | 90 | object e = scan_expression(expr, env); 91 | 92 | object x = execute(e, env, &last_was_assn); 93 | //object x = execute_expression(a, env, &last_was_assn); 94 | DEBUG(2, "last_was_assn = %d\n", last_was_assn); 95 | IFDEBUG(2, print(x, 10, 1)); 96 | 97 | if (!last_was_assn && x!=mark) 98 | print(x, 0, 1); 99 | } 100 | return 0; 101 | } 102 | 103 | void init_shortcuts(symtab st){ 104 | define_symbol(st, newdata(PCHAR, 'S'), areduce(vtab[VERB_PLUS], 0)); 105 | define_symbol(st, newdata(PCHAR, 'D'), ascan(vtab[VERB_PLUS], 0)); 106 | define_symbol(st, newdata(PCHAR, 'P'), areduce(vtab[VERB_MUL], 0)); 107 | define_symbol(st, newdata(PCHAR, 'R'), ascan(vtab[VERB_MUL], 0)); 108 | object i; 109 | define_symbol(st, newdata(PCHAR, 'i'), i = amp(amp(newdata(LITERAL, 1), vtab[VERB_PLUS], 0) ,vtab[VERB_IOTA], 0)); 110 | define_symbol(st, newdata(PCHAR, '!'), amp(areduce(vtab[VERB_MUL], 0), i, 0)); 111 | } 112 | 113 | void init_all(){ 114 | init_en(); 115 | init_array(); 116 | env = makesymtab(10); 117 | env->value = null; // set root-node value 118 | init_vb(env); 119 | init_av(env); 120 | init_xverb(env); 121 | init_quad_neg(env); 122 | init_quad_k(env); 123 | init_number(env); 124 | init_shortcuts(env); 125 | //print(inf, 0, 1); 126 | //print(neginf, 0, 1); 127 | setcursor(bar); 128 | } 129 | 130 | int main() { 131 | int do_tty = isatty(fileno(stdin)); 132 | init_all(); 133 | 134 | if (do_tty) specialtty(); 135 | 136 | mainloop(); 137 | 138 | if (do_tty) restoretty(); 139 | setcursor(block); 140 | return 0; 141 | } 142 | 143 | -------------------------------------------------------------------------------- /olmec/makefile: -------------------------------------------------------------------------------- 1 | CC=gcc --std=gnu99 2 | LDLIBS=-lm 3 | 4 | testprogs= $(notdir $(wildcard ./*_test.c)) 5 | unitprogs= $(subst _test,,$(testprogs)) 6 | tests= $(basename $(testprogs)) 7 | units= $(basename $(unitprogs)) 8 | unitobjs= $(patsubst %,%.o,$(units)) 9 | testexes= $(patsubst %,%.exe,$(tests)) 10 | LDLIBS+= -lmpfr -lgmp 11 | 12 | extraobjs= encoding.o print.o editor.o 13 | 14 | all:olmec test tables.md 15 | 16 | clean: 17 | rm -f *.o all_tests.c all_tests.exe $(testexes) 18 | 19 | %.md: %.tab %s.h 20 | cpp -P $< | \ 21 | tail -1 | \ 22 | sed 's/0x001f/\//g' | \ 23 | sed 's/0x001e/\\/g' | \ 24 | sed "s/'|'/0x2223/g" | \ 25 | sed 's/EOL */\ 26 | /g' | \ 27 | sed 's/0x\(\w*\)/\&#x\1;/g' | \ 28 | sed 's/\\\\/\\/' | \ 29 | sed "s/'\(.\)'/\1/" >$@ 30 | 31 | tables.md:adverb.md verb.md 32 | m4 tables.m4 >$@ 33 | 34 | 35 | test:all_tests $(tests) 36 | @./all_tests 37 | all_tests.c:all_tests.m4 makefile $(unitprogs) 38 | m4 -D UNITS="$(units)" $< >$@ 39 | all_tests:all_tests.c 40 | $(CC) $(CFLAGS) -o $@ $^ $(extraobjs) $(LDLIBS) 41 | array_test:array_test.c 42 | $(CC) $(CFLAGS) -o $@ $^ number.o symtab.o $(extraobjs) $(LDLIBS) 43 | symtab_test:symtab_test.c 44 | $(CC) $(CFLAGS) -o $@ $^ number.o array.o $(extraobjs) $(LDLIBS) 45 | number_test:number_test.c 46 | $(CC) $(CFLAGS) -o $@ $^ array.o symtab.o $(extraobjs) $(LDLIBS) 47 | 48 | olmec:main.o lex.o exec.o verbs.o adverbs.o xverb.o $(extraobjs) $(unitobjs) 49 | $(CC) $(CFLAGS) -o $@ $^ $(LDLIBS) 50 | 51 | -------------------------------------------------------------------------------- /olmec/minunit.h: -------------------------------------------------------------------------------- 1 | /* file: minunit.h 2 | cf.http://www.jera.com/techinfo/jtns/jtn002.html */ 3 | #define mu_assert(message, test) do { if (!(test)) return message; } while (0) 4 | #define mu_run_test(test) do { char *message = test(); tests_run++; \ 5 | if (message) return message; } while (0) 6 | 7 | #define test_case(c) do { if(c)return #c; } while(0) 8 | 9 | extern int tests_run; 10 | 11 | -------------------------------------------------------------------------------- /olmec/number.c: -------------------------------------------------------------------------------- 1 | //number.c 2 | //$make number LDLIBS='-lmpfr -lgmp' 3 | 4 | #include "array.h" 5 | #include "number.h" 6 | 7 | object neginf; 8 | object inf; 9 | 10 | object getprecision(symtab node){ 11 | //printf("getprecision()\n"); 12 | return newdata(LITERAL, (int)mpfr_get_default_prec()); 13 | } 14 | void setprecision(symtab node, object val){ 15 | //printf("setprecision()\n"); 16 | retry: 17 | switch(gettag(val)){ 18 | case LITERAL: mpfr_set_default_prec(getval(val)); break; 19 | case NUMBER: { 20 | number_ptr num = getptr(val); 21 | switch(num->tag){ 22 | case Z: mpfr_set_default_prec(mpz_get_si(num->z.z)); break; 23 | case FR: mpfr_set_default_prec(mpfr_get_si(num->fr.fr, MPFR_RNDN)); break; 24 | } 25 | } break; 26 | case ARRAY: { 27 | array a = getptr(val); 28 | val = *elem(a,0); 29 | goto retry; 30 | } 31 | default: printf("bad type in setprecision()"); break; 32 | } 33 | } 34 | 35 | static int printprec; 36 | static char *printfmt = NULL; 37 | 38 | object getprintprec(symtab node){ 39 | //printf("getprintprec()\n"); 40 | return newdata(LITERAL, printprec); 41 | } 42 | void setprintprec(symtab node, object val){ 43 | //printf("setprintprec()\n"); 44 | retry: 45 | switch(gettag(val)){ 46 | case LITERAL: printprec = getval(val); break; 47 | case NUMBER: { 48 | number_ptr num = getptr(val); 49 | switch(num->tag){ 50 | case Z: printprec = mpz_get_si(num->z.z); break; 51 | case FR: printprec = mpfr_get_si(num->fr.fr, MPFR_RNDN); break; 52 | } break; 53 | } 54 | case ARRAY: { 55 | array a = getptr(val); 56 | val = *elem(a,0); 57 | goto retry; 58 | } 59 | default: printf("bad type in setprintprec()"); return; 60 | } 61 | 62 | int n; 63 | printfmt = realloc(printfmt, (n = 1+ snprintf(NULL, 0, "%%.%dRf", printprec))); 64 | snprintf(printfmt, n, "%%.%dRf", printprec); 65 | //printf("using fmt:%s\n", printfmt); 66 | } 67 | 68 | void init_number(symtab env){ 69 | number_ptr num = calloc(1, sizeof *num); 70 | double d = strtod("-inf", NULL); 71 | init_fr(num); 72 | mpfr_set_d(num->fr.fr, d, MPFR_RNDN); 73 | neginf = cache(NUMBER, num); 74 | 75 | num = calloc(1, sizeof *num); 76 | init_fr(num); 77 | d = strtod("inf", NULL); 78 | mpfr_set_d(num->fr.fr, d, MPFR_RNDN); 79 | inf = cache(NUMBER, num); 80 | 81 | magic m = calloc(1, sizeof *m); 82 | m->get = getprecision; 83 | m->put = setprecision; 84 | define_symbol(env, newdata(PCHAR, 0x2395), //quad 85 | newdata(PCHAR, 'F'), newdata(PCHAR, 'P'), newdata(PCHAR, 'C'), 86 | cache(MAGIC, m)); 87 | 88 | m = calloc(1, sizeof *m); 89 | m->get = getprintprec; 90 | m->put = setprintprec; 91 | define_symbol(env, newdata(PCHAR, 0x2395), 92 | newdata(PCHAR, 'P'), newdata(PCHAR, 'P'), 93 | cache(MAGIC, m)); 94 | setprintprec(NULL, 6); 95 | } 96 | 97 | void init_z(number_ptr z){ 98 | z->z.tag = Z; 99 | mpz_init(z->z.z); 100 | } 101 | 102 | void init_fr(number_ptr fr){ 103 | fr->fr.tag = FR; 104 | mpfr_init(fr->fr.fr); 105 | } 106 | 107 | number_ptr new_z(){ 108 | number_ptr num = calloc(1, sizeof *num); 109 | num->z.tag = Z; 110 | mpz_init(num->z.z); 111 | return num; 112 | } 113 | 114 | number_ptr new_fr(){ 115 | number_ptr num = calloc(1, sizeof *num); 116 | num->fr.tag = FR; 117 | mpfr_init(num->fr.fr); 118 | return num; 119 | } 120 | 121 | number_ptr new_number_z(char *str){ 122 | number_ptr num = new_z(); 123 | mpz_set_str(num->z.z, str, 10); 124 | return num; 125 | } 126 | 127 | number_ptr new_number_fr(char *str){ 128 | number_ptr num = calloc(1, sizeof *num); 129 | num->fr.tag = FR; 130 | mpfr_init_set_str(num->fr.fr, str, 10, MPFR_RNDN); 131 | return num; 132 | } 133 | 134 | number_ptr new_number_lit(int lit){ 135 | number_ptr num = calloc(1, sizeof *num); 136 | num->z.tag = Z; 137 | mpz_init_set_si(num->z.z, lit); 138 | return num; 139 | } 140 | 141 | typedef number_ptr binop(number_ptr x, number_ptr y); 142 | typedef number_ptr unop(number_ptr x); 143 | 144 | number_ptr return_inf(number_ptr dummy1, number_ptr dummy2){ 145 | return getptr(inf); 146 | } 147 | 148 | 149 | number_ptr add_z_z(number_ptr x, number_ptr y){ 150 | number_ptr z = new_z(); 151 | mpz_add(z->z.z, x->z.z, y->z.z); 152 | return z; 153 | } 154 | 155 | number_ptr add_z_fr(number_ptr x, number_ptr y){ 156 | number_ptr z = new_fr(); 157 | mpfr_add_z(z->fr.fr, y->fr.fr, x->z.z, MPFR_RNDN); 158 | return z; 159 | } 160 | 161 | number_ptr add_fr_z(number_ptr x, number_ptr y){ 162 | number_ptr z = new_fr(); 163 | mpfr_add_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 164 | return z; 165 | } 166 | 167 | number_ptr add_fr_fr(number_ptr x, number_ptr y){ 168 | number_ptr z = new_fr(); 169 | mpfr_add(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 170 | return z; 171 | } 172 | 173 | number_ptr number_add(number_ptr x, number_ptr y){ 174 | binop *f[] = { 175 | return_inf, return_inf, return_inf, 176 | return_inf, add_z_z, add_z_fr, 177 | return_inf, add_fr_z, add_fr_fr 178 | }; 179 | return f [x->tag*NTAGS+y->tag] (x,y); 180 | } 181 | 182 | 183 | number_ptr sub_z_z(number_ptr x, number_ptr y){ 184 | number_ptr z = new_z(); 185 | mpz_sub(z->z.z, x->z.z, y->z.z); 186 | return z; 187 | } 188 | 189 | number_ptr sub_z_fr(number_ptr x, number_ptr y){ 190 | number_ptr z = new_fr(); 191 | mpfr_z_sub(z->fr.fr, x->z.z, y->fr.fr, MPFR_RNDN); 192 | return z; 193 | } 194 | 195 | number_ptr sub_fr_z(number_ptr x, number_ptr y){ 196 | number_ptr z = new_fr(); 197 | mpfr_sub_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 198 | return z; 199 | } 200 | 201 | number_ptr sub_fr_fr(number_ptr x, number_ptr y){ 202 | number_ptr z = new_fr(); 203 | mpfr_sub(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 204 | return z; 205 | } 206 | 207 | number_ptr number_sub(number_ptr x, number_ptr y){ 208 | binop *f[] = { 209 | return_inf, return_inf, return_inf, 210 | return_inf, sub_z_z, sub_z_fr, 211 | return_inf, sub_fr_z, sub_fr_fr 212 | }; 213 | return f [x->tag*NTAGS+y->tag] (x,y); 214 | } 215 | 216 | 217 | number_ptr mul_z_z(number_ptr x, number_ptr y){ 218 | number_ptr z = new_z(); 219 | mpz_mul(z->z.z, x->z.z, y->z.z); 220 | return z; 221 | } 222 | 223 | number_ptr mul_z_fr(number_ptr x, number_ptr y){ 224 | number_ptr z = new_fr(); 225 | mpfr_mul_z(z->fr.fr, y->fr.fr, x->z.z, MPFR_RNDN); 226 | return z; 227 | } 228 | 229 | number_ptr mul_fr_z(number_ptr x, number_ptr y){ 230 | number_ptr z = new_fr(); 231 | mpfr_mul_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 232 | return z; 233 | } 234 | 235 | number_ptr mul_fr_fr(number_ptr x, number_ptr y){ 236 | number_ptr z = new_fr(); 237 | mpfr_mul(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 238 | return z; 239 | } 240 | 241 | number_ptr number_mul(number_ptr x, number_ptr y){ 242 | binop *f[] = { 243 | return_inf, return_inf, return_inf, 244 | return_inf, mul_z_z, mul_z_fr, 245 | return_inf, mul_fr_z, mul_fr_fr 246 | }; 247 | return f [x->tag*NTAGS+y->tag] (x,y); 248 | } 249 | 250 | 251 | number_ptr div_z_z(number_ptr x, number_ptr y){ 252 | number_ptr z = new_fr(); 253 | number_promote(x); 254 | mpfr_div_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 255 | return z; 256 | } 257 | 258 | number_ptr div_z_fr(number_ptr x, number_ptr y){ 259 | number_ptr z = new_fr(); 260 | number_promote(x); 261 | mpfr_div(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 262 | return z; 263 | } 264 | 265 | number_ptr div_fr_z(number_ptr x, number_ptr y){ 266 | number_ptr z = new_fr(); 267 | mpfr_div_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 268 | return z; 269 | } 270 | 271 | number_ptr div_fr_fr(number_ptr x, number_ptr y){ 272 | number_ptr z = new_fr(); 273 | mpfr_div(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 274 | return z; 275 | } 276 | 277 | number_ptr number_div(number_ptr x, number_ptr y){ 278 | binop *f[] = { 279 | return_inf, return_inf, return_inf, 280 | return_inf, div_z_z, div_z_fr, 281 | return_inf, div_fr_z, div_fr_fr 282 | }; 283 | return f [x->tag*NTAGS+y->tag] (x,y); 284 | } 285 | 286 | 287 | number_ptr mod_z_z(number_ptr x, number_ptr y){ 288 | number_ptr z = new_z(); 289 | mpz_mod(z->z.z, x->z.z, y->z.z); 290 | return z; 291 | } 292 | 293 | number_ptr mod_z_fr(number_ptr x, number_ptr y){ 294 | number_ptr z = new_fr(); 295 | number_promote(x); 296 | mpfr_fmod(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 297 | return z; 298 | } 299 | 300 | number_ptr mod_fr_z(number_ptr x, number_ptr y){ 301 | number_ptr z = new_fr(); 302 | number_promote(y); 303 | mpfr_fmod(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 304 | return z; 305 | } 306 | 307 | number_ptr mod_fr_fr(number_ptr x, number_ptr y){ 308 | number_ptr z = new_fr(); 309 | mpfr_fmod(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 310 | return z; 311 | } 312 | 313 | number_ptr number_mod(number_ptr x, number_ptr y){ 314 | binop *f[] = { 315 | return_inf, return_inf, return_inf, 316 | return_inf, mod_z_z, mod_z_fr, 317 | return_inf, mod_fr_z, mod_fr_fr 318 | }; 319 | return f [x->tag*NTAGS+y->tag] (x,y); 320 | } 321 | 322 | 323 | number_ptr pow_z_z(number_ptr x, number_ptr y){ 324 | number_ptr z = new_fr(); 325 | number_promote(x); 326 | mpfr_pow_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 327 | return z; 328 | } 329 | 330 | number_ptr pow_z_fr(number_ptr x, number_ptr y){ 331 | number_ptr z = new_fr(); 332 | number_promote(x); 333 | mpfr_pow(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 334 | return z; 335 | } 336 | 337 | number_ptr pow_fr_z(number_ptr x, number_ptr y){ 338 | number_ptr z = new_fr(); 339 | mpfr_pow_z(z->fr.fr, x->fr.fr, y->z.z, MPFR_RNDN); 340 | return z; 341 | } 342 | 343 | number_ptr pow_fr_fr(number_ptr x, number_ptr y){ 344 | number_ptr z = new_fr(); 345 | mpfr_pow(z->fr.fr, x->fr.fr, y->fr.fr, MPFR_RNDN); 346 | return z; 347 | } 348 | 349 | number_ptr number_pow(number_ptr x, number_ptr y){ 350 | binop *f[] = { 351 | return_inf, return_inf, return_inf, 352 | return_inf, pow_z_z, pow_z_fr, 353 | return_inf, pow_fr_z, pow_fr_fr 354 | }; 355 | return f [x->tag*NTAGS+y->tag] (x,y); 356 | } 357 | 358 | 359 | number_ptr number_neg(number_ptr x){ 360 | number_ptr z = calloc(1, sizeof *z); 361 | switch(x->tag){ 362 | case Z: init_z(z); mpz_neg(z->z.z, x->z.z); break; 363 | case FR: init_fr(z); mpfr_neg(z->fr.fr, x->fr.fr, MPFR_RNDN); break; 364 | } 365 | return z; 366 | } 367 | 368 | number_ptr number_abs(number_ptr x){ 369 | number_ptr z = calloc(1, sizeof *z); 370 | switch(x->tag){ 371 | case Z: init_z(z); mpz_abs(z->z.z, x->z.z); break; 372 | case FR: init_fr(z); mpfr_abs(z->fr.fr, x->fr.fr, MPFR_RNDN); break; 373 | } 374 | return z; 375 | } 376 | 377 | int number_cmp(number_ptr x, number_ptr y){ 378 | switch(x->tag){ 379 | case Z: switch(y->tag){ 380 | case Z: return mpz_cmp(x->z.z, y->z.z); 381 | case FR: return mpfr_cmp_z(x->fr.fr, y->z.z); 382 | } 383 | case FR: switch(y->tag){ 384 | case Z: return mpfr_cmp_z(y->fr.fr, x->z.z); 385 | case FR: return mpfr_cmp(x->fr.fr, y->fr.fr); 386 | } 387 | } 388 | return 0; 389 | } 390 | 391 | number_ptr number_eq(number_ptr x, number_ptr y){ 392 | number_ptr z = new_z(); 393 | mpz_set_si(z->z.z, number_cmp(x,y)==0); 394 | return z; 395 | } 396 | 397 | number_ptr number_ne(number_ptr x, number_ptr y){ 398 | number_ptr z = new_z(); 399 | mpz_set_si(z->z.z, number_cmp(x,y)!=0); 400 | return z; 401 | } 402 | 403 | int number_get_int(number_ptr x){ 404 | switch(x->tag){ 405 | case Z: return mpz_get_si(x->z.z); 406 | case FR: return mpfr_get_si(x->fr.fr, MPFR_RNDN); 407 | } 408 | } 409 | 410 | char *number_get_str(number_ptr num){ 411 | char *fmt = printfmt; 412 | char *str; 413 | switch(num->tag){ 414 | case Z: str = mpz_get_str(NULL, 10, num->z.z); 415 | break; 416 | case FR: { 417 | int n = mpfr_snprintf(NULL, 0, fmt, num->fr.fr); 418 | str = calloc(1, n+1); 419 | mpfr_snprintf(str, n+1, fmt, num->fr.fr); 420 | } 421 | } 422 | return str; 423 | } 424 | 425 | int number_print_width(number_ptr num){ 426 | switch(num->tag){ 427 | case Z: 428 | return mpz_sizeinbase(num->z.z, 10) + mpz_sgn(num->z.z)==-1; 429 | case FR: 430 | return mpfr_snprintf(NULL, 0, printfmt, num->fr.fr); 431 | } 432 | return 0; 433 | } 434 | 435 | void number_promote(number_ptr n){ 436 | mpz_t t; 437 | memcpy(&t, &n->z.z, sizeof t); 438 | init_fr(n); 439 | mpfr_set_z(n->fr.fr, t, MPFR_RNDN); 440 | mpz_clear(t); 441 | } 442 | 443 | #ifdef TESTMODULE 444 | int tests_run; 445 | 446 | #define op(func, C, A, B) \ 447 | if ((A)->tag==Z && (B)->tag==Z) { \ 448 | if (!strcmp(#func,"div")) { \ 449 | init_fr(C); \ 450 | number_promote(A); \ 451 | number_promote(B); \ 452 | mpfr_##func((C)->fr.fr, (A)->fr.fr, (B)->fr.fr, MPFR_RNDN); \ 453 | } else { \ 454 | init_z(C); \ 455 | mpz_##func((C)->z.z, (A)->z.z, (B)->z.z); \ 456 | } \ 457 | } else if ((A)->tag==FR && (B)->tag==FR) { \ 458 | init_fr(C); \ 459 | mpfr_##func((C)->fr.fr, (A)->fr.fr, (B)->fr.fr, MPFR_RNDN); \ 460 | } 461 | 462 | void mpz_nothing(mpz_t c, const mpz_t a, const mpz_t b){ 463 | mpz_set_ui(c,0); 464 | } 465 | 466 | void mpfr_nothing(mpfr_t c, const mpfr_t a, const mpfr_t b, mpfr_rnd_t rnd){ 467 | mpfr_set_ui(c,0,rnd); 468 | } 469 | 470 | int main(){ 471 | number a, b, c; 472 | char op[2]; 473 | init_z(a); 474 | init_z(b); 475 | 476 | return 0; 477 | gmp_scanf("%Zd %1s %Zd", a->z.z, op, b->z.z); 478 | switch(*op){ 479 | case '+': op(add, c, a, b); break; 480 | case '*': op(mul, c, a, b); break; 481 | case '-': op(sub, c, a, b); break; 482 | case '/': op(div, c, a, b); break; 483 | default: op(nothing, c, a, b); 484 | } 485 | switch(c->tag){ 486 | case Z: gmp_printf("%Zd\n", c->z.z); break; 487 | case FR: mpfr_printf("%Rf\n", c->fr.fr); break; 488 | } 489 | return 0; 490 | } 491 | 492 | #endif 493 | -------------------------------------------------------------------------------- /olmec/number.h: -------------------------------------------------------------------------------- 1 | #ifndef NUMBER_H 2 | #define NUMBER_H 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #include "common.h" 13 | #include "encoding.h" 14 | #include "symtab.h" 15 | 16 | enum numtag { NONE, Z, FR, NTAGS }; 17 | 18 | typedef union { 19 | enum numtag tag; 20 | struct z { 21 | enum numtag tag; 22 | mpz_t z; 23 | } z; 24 | struct fr { 25 | enum numtag tag; 26 | mpfr_t fr; 27 | } fr; 28 | } u_number; 29 | typedef u_number number[1]; 30 | typedef u_number *number_ptr; 31 | 32 | extern object neginf; 33 | extern object inf; 34 | 35 | void init_number(symtab env); 36 | 37 | void init_z(number_ptr z); 38 | void init_fr(number_ptr fr); 39 | number_ptr new_number_z(char *str); 40 | number_ptr new_number_fr(char *str); 41 | number_ptr new_number_lit(int lit); 42 | 43 | number_ptr number_add(number_ptr x, number_ptr y); 44 | number_ptr number_sub(number_ptr x, number_ptr y); 45 | number_ptr number_mul(number_ptr x, number_ptr y); 46 | number_ptr number_div(number_ptr x, number_ptr y); 47 | number_ptr number_mod(number_ptr x, number_ptr y); 48 | number_ptr number_pow(number_ptr x, number_ptr y); 49 | number_ptr number_neg(number_ptr x); 50 | number_ptr number_abs(number_ptr x); 51 | number_ptr number_eq(number_ptr x, number_ptr y); 52 | number_ptr number_ne(number_ptr x, number_ptr y); 53 | 54 | int number_get_int(number_ptr x); 55 | void number_promote(number_ptr n); 56 | int number_print_width(number_ptr num); 57 | char *number_get_str(number_ptr num); 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /olmec/number_test.c: -------------------------------------------------------------------------------- 1 | #define TESTMODULE 2 | #include "number.c" 3 | -------------------------------------------------------------------------------- /olmec/olmec_wizard.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/luser-dr00g/inca/d369b9827158a6bb7caca9d2b85bef23e0cdf3fe/olmec/olmec_wizard.jpg -------------------------------------------------------------------------------- /olmec/print.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include "editor.h" 6 | #include "encoding.h" 7 | #include "symtab.h" 8 | #include "array.h" 9 | #include "verbs.h" 10 | #include "xverb.h" 11 | #include "number.h" 12 | #include "print.h" 13 | 14 | 15 | int printarray(array t, int width); 16 | 17 | /* return 1 if element is nonscalar */ 18 | int checkatom(object x, int *pwidth){ 19 | switch(gettag(x)){ 20 | case NULLOBJ: 21 | *pwidth = strlen("NULL"); 22 | return 0; 23 | case CHAR: 24 | case PCHAR: 25 | *pwidth = 1; 26 | return 0; 27 | case LITERAL: 28 | *pwidth = snprintf(NULL, 0, "%d", getval(x)); 29 | return 0; 30 | case NUMBER: 31 | *pwidth = number_print_width(getptr(x)); 32 | return 0; 33 | case PROG: 34 | *pwidth = 0; 35 | return 0; 36 | case EXPR: 37 | *pwidth = 1; 38 | return 1; 39 | case ARRAY: 40 | *pwidth = 2; 41 | return 1; 42 | default: 43 | *pwidth = strlen("00000000(00,0000)"); 44 | return 1; 45 | } 46 | } 47 | 48 | int printatom(object x, int width){ 49 | switch(gettag(x)){ 50 | case NULLOBJ: printf("NULL"); 51 | break; 52 | case MARKOBJ: printf("%s", basetooutput(0x22c4)); 53 | break; 54 | case CHAR: 55 | case PCHAR: 56 | if (width) 57 | printf(" %*s", width, basetooutput(getval(x))); 58 | else 59 | printf("%s", basetooutput(getval(x))); 60 | break; 61 | case VERB: { 62 | verb v = getptr(x); 63 | if (v->f||v->g) printf("("); 64 | if (v->f) print(v->f, width, 0); 65 | printf("%*s", width, basetooutput(getval(v->id))); 66 | if (v->g) print(v->g, width, 0); 67 | if (v->f||v->g) printf(")"); 68 | break; 69 | } 70 | case ADVERB: { 71 | verb v = getptr(x); 72 | if (v->f||v->g) printf("("); 73 | if (v->f) print(v->f, width, 0); 74 | printf("%*s", width, basetooutput(getval(v->id))); 75 | if (v->g) print(v->g, width, 0); 76 | if (v->f||v->g) printf(")"); 77 | break; 78 | } 79 | case XVERB: 80 | printf("%*s", width, 81 | basetooutput(getval( ((xverb)getptr(x))->id ))); break; 82 | case LITERAL: 83 | printf(" %*d", width, getval(x)); break; 84 | case NUMBER: 85 | printf(" %s", number_get_str(getptr(x))); break; 86 | default: 87 | printf(" %08x(%d,%d)", x, gettag(x), getval(x)); 88 | } 89 | return width; 90 | } 91 | 92 | void printindexdisplay(array t){ 93 | //printf("\n"); 94 | DEBUG(3,"%d\n",t->rank); 95 | printf("%s", basetooutput(0x2374)); // rho 96 | for (int i=0; irank; i++) 97 | printf("%d ", t->dims[i]); 98 | //printf("\n"); 99 | 100 | int n = productdims(t->rank,t->dims); 101 | DEBUG(3,"n=%d", n); 102 | printf("\n"); 103 | int scratch[t->rank]; 104 | for (int i=0; idims,t->rank,scratch)); 106 | char *app = ""; 107 | for (int j=0; jrank; j++, app=",") 108 | printf("%s%d", app, scratch[j]); 109 | printf(": "); 110 | DEBUG(3,"%08x(%d,%d)", xx, gettag(xx), getval(xx)); 111 | //printf("\n"); 112 | switch(gettag(xx)){ 113 | case CHAR: 114 | case PCHAR: 115 | printf(" %s", basetooutput(getval(xx))); 116 | printf("\n"); 117 | break; 118 | case ADVERB: 119 | case VERB: 120 | printf(" %s", 121 | basetooutput(getval( 122 | ((verb)getptr(xx))->id ))); 123 | printf("\n"); 124 | break; 125 | case LITERAL: 126 | printf(" %d", getval(xx)); 127 | printf("\n"); 128 | break; 129 | case PROG: 130 | print(xx, 1, 1); 131 | break; 132 | case EXPR: 133 | case BLOCK: 134 | case ARRAY: 135 | print(xx, 0, 1); 136 | break; 137 | } 138 | } 139 | printf("\n"); 140 | } 141 | 142 | 143 | int printarray(array t, int width){ 144 | IFDEBUG(3, printindexdisplay(t)); 145 | t = makesolid(t); 146 | int maxwidth; 147 | int nonscalar = 0; 148 | 149 | if (width){ maxwidth = width; } 150 | else { 151 | int n = productdims(t->rank,t->dims); 152 | if (n==0) { 153 | printf("NIL\n"); 154 | return 0; 155 | } 156 | 157 | maxwidth = 0; 158 | for (int i=0; idata[i], &size)) 161 | break; 162 | if (size>maxwidth) 163 | maxwidth = size; 164 | } 165 | } 166 | 167 | if (nonscalar) 168 | printindexdisplay(t); 169 | else 170 | switch(t->rank){ 171 | case 0: //DEBUG(1,"%*d\n", maxwidth, *t->data); 172 | printatom(t->data[t->cons], maxwidth); 173 | break; 174 | case 1: for (int i=0; idims[0]; ++i) { 175 | //DEBUG(1,"%*d\n", maxwidth, *elem(t,i)); 176 | printatom(*elem(t,i), maxwidth); 177 | } 178 | break; 179 | default: 180 | for (int i=0; idims[0]; ++i, printf("\n")){ 181 | array ts = slice(t,i); 182 | printarray(ts, maxwidth); 183 | free(ts); 184 | } 185 | break; 186 | } 187 | return maxwidth; 188 | } 189 | 190 | 191 | void print(object x, int width, int newline){ 192 | DEBUG(3,"%08x(%d,%d)", x, gettag(x), getval(x)); 193 | switch(gettag(x)){ 194 | default: printatom(x, width); 195 | if (newline) printf("\n"); 196 | break; 197 | case EXPR: 198 | case BLOCK: 199 | case PROG: 200 | case ARRAY: { 201 | array t = getptr(x); 202 | printarray(t, width); 203 | if (newline) printf("\n"); 204 | 205 | } break; 206 | } 207 | } 208 | 209 | -------------------------------------------------------------------------------- /olmec/print.h: -------------------------------------------------------------------------------- 1 | // if width=0, print will scan for the appropriate width 2 | void print(object x, int width, int newline); 3 | int printarray(array t, int width); 4 | void printindexdisplay(array t); 5 | -------------------------------------------------------------------------------- /olmec/symtab.c: -------------------------------------------------------------------------------- 1 | /* Symbol Table 2 | * 3 | * As a symbol-table for a Unicode-capable programming language 4 | * interpreter, I decided to combine the 3 types of associative 5 | * array that I had implemented before. Xpost's postscript 6 | * nametype objects are implemented with a ternary search tree, 7 | * and its dicttype objects are implemented with a hash table. 8 | * Inca3's symbol table used a trie tree to hold variable-length 9 | * keys. 10 | * 11 | * As a trie, it collapses similar prefixes from the keys. 12 | * For "abc", "aaa", "abb", and "add", we get the structure: 13 | * a - a - a 14 | * - b - b 15 | * - c 16 | * - d - d 17 | * 18 | * Every key has the same prefix "a" so it is represented 19 | * exactly once. 20 | * 21 | * The Inca3 trie allows only alphabetic characters in symbols, 22 | * so each node could contain an array of 52 pointers. But to 23 | * adapt this code for Unicode code points, millions of pointers 24 | * in each node seems grossly impractical. So the child nodes 25 | * from each node are organized into a hash table keyed to the 26 | * single character where they diverge from the tree. 27 | * 28 | * In the example above, ('a', 'b', 'd') and ('b', 'c') are 29 | * collected in hash tables. There are also degenerate hash 30 | * tables at each of the leaf nodes which are all null. 31 | * 32 | * So, each node contains a value or null. Each node also 33 | * contains a pointer to a table of child nodes which is 34 | * accessed via a hash lookup on a single char (code-point) of 35 | * the key string. If the key string is not exhausted, lookup 36 | * continues on the child nodes of the matched node. 37 | * 38 | * Taking advantage of the prefix-collapsing nature of the 39 | * data-structure, The symbol-lookup mechanism will fallback 40 | * to returning the longest-defined prefix if the full symbol 41 | * cannot be found. Assuming this to represent two (or more) 42 | * juxtaposed symbols, symbol-lookup may then proceed upon 43 | * the remainder of the key string. see ex.c:parse_and_lookup_name 44 | * 45 | * The master lookup function has two search modes: 46 | * a prefix mode where it returns the first defined value and 47 | * updates the symbol-string pointer and returns. 48 | * Or it can be called in the "defining" mode where 49 | * it follows existing links and creates new nodes until 50 | * the search string is exhausted. 51 | * 52 | * In support of Weizenbaum environment chaining for functions 53 | * there is now another search option called "bias" which is only 54 | * relevant for defining searches. If bias is nonzero, search 55 | * will restart on the prev root before defining new nodes on 56 | * the current root. This is because defined functions must 57 | * declare the local variables to be used. Remaining variable 58 | * references are to global variables (in the "workspace" or session). 59 | */ 60 | #include 61 | #include 62 | 63 | #include "array.h" 64 | #include "encoding.h" 65 | #include "print.h" 66 | 67 | #include "symtab.h" 68 | 69 | /* construct a new symbol table with n slots */ 70 | symtab makesymtab(int n){ 71 | symtab z = malloc(sizeof *z); 72 | if (z){ 73 | z->key = null; // key int transitioning into this node 74 | z->value = null; // associated value 75 | z->n = n; // num slots in table 76 | z->tab = calloc(n, sizeof *z->tab); // hashtable of child nodes 77 | z->prev = NULL; 78 | } 79 | return z; 80 | } 81 | 82 | symtab makesymtabchain(symtab root, int n){ 83 | symtab z = makesymtab(n); 84 | z->prev = root; 85 | return z; 86 | } 87 | 88 | int hash(int x){ 89 | return x^(x<<2); 90 | //return x^(x<<5)^(x<<14); // fill UCS 21bit space with 7bit ascii 91 | } 92 | 93 | /* common test clause in hashlookup */ 94 | #define RETURN_TAB_I_IF_EQ_K_OR_NULL \ 95 | if (st->tab[i] == NULL || st->tab[i]->key == k) \ 96 | return &st->tab[i] 97 | 98 | /* compute hash, 99 | scan table */ 100 | symtab *hashlookup(symtab st, int k){ 101 | int i; 102 | int h; 103 | unsigned int sz = st->n; 104 | 105 | h = hash(k) % sz; 106 | i = h; 107 | RETURN_TAB_I_IF_EQ_K_OR_NULL; // test slot h 108 | for (++i; i < sz; i++) 109 | RETURN_TAB_I_IF_EQ_K_OR_NULL; // test slots [h+1..sz) 110 | for (i=0; i < h; i++) 111 | RETURN_TAB_I_IF_EQ_K_OR_NULL; // test slots [0..h-1] 112 | return NULL; // :not found 113 | } 114 | 115 | /* to rehash, we make a new table of the appropriate size, 116 | copy all non-null entries to new table 117 | steal the new table and update n */ 118 | void rehash(symtab st){ 119 | int n = st->n * 7 + 11; // large growth to avoid thrashing, 120 | // primes to avoid power-of-2 sizes 121 | // for better distribution under modulus 122 | // (maybe) (that's the idea, anyway) 123 | int i; 124 | symtab z=makesymtab(n); // allocate new table z->tab 125 | symtab *t = NULL; // temp pointer 126 | 127 | for (i=0; in; i++){ 128 | if (st->tab[i]){ 129 | t = hashlookup(z, st->tab[i]->key); 130 | *t = st->tab[i]; 131 | } 132 | } 133 | 134 | free(st->tab); // free original table 135 | st->tab = z->tab; // steal new table 136 | st->n = n; // update n 137 | free(z); // free new block 138 | } 139 | 140 | /* find the associated node for a(n integer) string. 141 | string is passed by reference in case of prefix match, 142 | in which case the original string is updated to point 143 | to the unmatched remainder. 144 | mode=0: prefix match 145 | mode=1: defining search 146 | 147 | bias=0: define local 148 | bias=1: define global unless local def exists 149 | */ 150 | symtab findsym(symtab st, object **spp, int *n, int mode, int bias){ 151 | symtab root = st; 152 | symtab last = st; // saved last-match value of st 153 | #define sp (*spp) // sp is an (int*) "by reference" 154 | int *lasp = sp; // saved last-match pointer 155 | symtab *t = NULL; // temp pointer 156 | int nn = *n; // working copy of n 157 | int lasn = nn; // saved last-match value of n 158 | 159 | IFDEBUG(1, for (int i=0; i<*n; ++i) 160 | print(sp[i], 0, 1); ); 161 | 162 | while(nn--){ 163 | t = hashlookup(st, *sp); 164 | if (!t) { // received NULL: table full 165 | rehash(st); 166 | t = hashlookup(st, *sp); 167 | } 168 | // t is now a pointer to a slot 169 | if (*t) { // slot not empty 170 | st = *t; 171 | sp++; 172 | if ((*t)->value != null){ // save partial match 173 | last = st; 174 | lasp = sp; 175 | lasn = nn; 176 | } 177 | } else { // slot empty 178 | switch(mode){ 179 | case 0: // prefix search : return last partial match 180 | sp = lasp; 181 | *n = lasn; 182 | goto ret_last; 183 | case 1: // defining search 184 | if (bias && root->prev) 185 | goto recurse; 186 | *t = calloc(1, sizeof(struct symtab)); 187 | (*t)->tab = calloc((*t)->n = 11, sizeof(struct symtab)); 188 | st = *t; 189 | lasn = nn; 190 | lasp = sp; 191 | last = st; 192 | st->key = *sp++; 193 | st->value = null; 194 | break; 195 | } 196 | } 197 | } 198 | 199 | //*n = nn+1; // undo nn-- and update n 200 | sp = lasp; 201 | *n = lasn; 202 | ret_last: 203 | if (last == root && root->prev) //not-found::recurse down the chain. 204 | recurse: 205 | return findsym(root->prev, spp, n, mode, bias); 206 | return last; // return last-matched node 207 | } 208 | #undef sp 209 | 210 | object getsym(symtab node){ 211 | if (gettag(node->value)==MAGIC){ 212 | magic m = getptr(node->value); 213 | return m->get(node); 214 | } 215 | return node->value; 216 | } 217 | 218 | void putsym(symtab node, object val){ 219 | if (gettag(node->value)==MAGIC){ 220 | magic m = getptr(node->value); 221 | m->put(node, val); 222 | return; 223 | } 224 | node->value = val; 225 | } 226 | 227 | void def(symtab st, object name, object v, int bias){ 228 | symtab tab; 229 | switch(gettag(name)){ 230 | default: 231 | case CHAR: 232 | case PCHAR:{ 233 | int n = 1; 234 | object *p = &name; 235 | DEBUG(2,"%08x(%d,%d) = %08x(%d,%d)\n", 236 | name, gettag(name), getval(name), 237 | v, gettag(v), getval(v)); 238 | tab = findsym(st,&p,&n,1,bias); 239 | } break; 240 | case PROG: { 241 | array na = getptr(name); 242 | int n = na->dims[0]; 243 | object *p = na->data; 244 | tab = findsym(st,&p,&n,1,bias); 245 | } break; 246 | } 247 | putsym(tab, v); 248 | } 249 | 250 | object find(symtab st, object name){ 251 | symtab tab; 252 | switch(gettag(name)){ 253 | default: 254 | case CHAR: 255 | case PCHAR:{ 256 | int n = 1; 257 | object *p = &name; 258 | tab = findsym(st, &p, &n, 0,0); 259 | } break; 260 | case PROG: { 261 | array na = getptr(name); 262 | int n = na->dims[0]; 263 | object *p = na->data; 264 | tab = findsym(st, &p, &n, 0,0); 265 | } break; 266 | } 267 | return getsym(tab); 268 | } 269 | 270 | void (define_symbol_n)(symtab st, int n, ...){ 271 | va_list ap; 272 | int key[n-1]; 273 | object *p = key; 274 | 275 | va_start(ap,n); 276 | for (int i=0; i 305 | 306 | struct symtab st = { .key = 0, .value = 0, .n = 10, .tab=(struct symtab *[10]){0} }; 307 | 308 | static char *test_put_get(){ 309 | int array[] = {48,49,50}; 310 | int *sym; 311 | int n; 312 | symtab t; 313 | 314 | sym = array; 315 | n = 3; 316 | t = findsym(&st,&sym,&n,1,0); 317 | //printf("%p\n",(void*)t); 318 | t->value = 42; 319 | 320 | sym = array; 321 | n = 3; 322 | t = findsym(&st,&sym,&n,0,0); 323 | //printf("%p\n",(void*)t); 324 | test_case(t->value != 42); 325 | printf("%d\n", n); 326 | test_case(n != 0); 327 | 328 | return 0; 329 | } 330 | 331 | static char *test_new_functions(){ 332 | symtab st = makesymtab(10); 333 | define_symbol(st, 's','y','m','b', 42); 334 | 335 | test_case(symbol_value(st, 's','y','m','b') != 42); 336 | return 0; 337 | } 338 | 339 | static char *test_null_all_bits_zero(){ 340 | char **calloc_ed_pointer = calloc(1,sizeof*calloc_ed_pointer); 341 | test_case(*calloc_ed_pointer!=NULL); 342 | free(calloc_ed_pointer); 343 | return 0; 344 | } 345 | 346 | static char *all_tests(){ 347 | mu_run_test(test_null_all_bits_zero); 348 | mu_run_test(test_put_get); 349 | mu_run_test(test_new_functions); 350 | return 0; 351 | } 352 | 353 | int main() { 354 | 355 | char *result=all_tests(); 356 | if (result != 0) { 357 | printf("%s\n",result); 358 | } else { 359 | printf("ALL TESTS PASSED\n"); 360 | } 361 | printf("Tests run: %d\n", tests_run); 362 | return result != 0; 363 | 364 | } 365 | #endif //defined TESTMODULE 366 | 367 | -------------------------------------------------------------------------------- /olmec/symtab.h: -------------------------------------------------------------------------------- 1 | #ifndef SYMBOL_H_ 2 | #define SYMBOL_H_ 3 | #include "common.h" 4 | /* symbol table */ 5 | 6 | struct symtab { 7 | object key; 8 | object value; 9 | int n; 10 | symtab *tab /*[n]*/ ; 11 | symtab prev; //==NULL in root and all leafs. used to chain (stack) new roots. 12 | }; 13 | 14 | struct magic { 15 | object (*get)(symtab node); 16 | void (*put)(symtab node, object val); 17 | }; 18 | 19 | symtab makesymtab(int n); 20 | symtab makesymtabchain(symtab root, int n); 21 | 22 | /* mode=0: prefix match 23 | mode=1: defining search */ 24 | symtab findsym(symtab st, object **spp, int *n, int mode, int bias); 25 | 26 | /* get/set node value */ 27 | object getsym(symtab node); 28 | void putsym(symtab node, object val); 29 | 30 | void def(symtab st, object name, object v, int bias); 31 | 32 | object find(symtab st, object name); 33 | 34 | #define define_symbol(st, ...) \ 35 | (define_symbol_n)(st, PP_NARG(__VA_ARGS__), __VA_ARGS__) 36 | void (define_symbol_n)(symtab st, int n, ... /* ..., v */); 37 | 38 | #define symbol_value(st, ...) \ 39 | (symbol_value_n)(st, PP_NARG(__VA_ARGS__), __VA_ARGS__) 40 | object (symbol_value_n)(symtab st, int n, ...); 41 | 42 | #endif 43 | -------------------------------------------------------------------------------- /olmec/symtab_test.c: -------------------------------------------------------------------------------- 1 | #define TESTMODULE 2 | #include "symtab.c" 3 | -------------------------------------------------------------------------------- /olmec/tables.m4: -------------------------------------------------------------------------------- 1 | 2 | ## Adverbs and Conjunctions: 3 | ie. monadic and dyadic operators. 4 | 5 | symbol | adverb | desc | conjunction | desc 6 | --- | --- | --- | --- | --- 7 | include(adverb.md) 8 | 9 | ## monadic and dyadic Verbs: 10 | ie. unary and binary functions 11 | 12 | symbol | monadic | desc | dyadic | desc 13 | --- | --- | --- | --- | --- 14 | include(verb.md) 15 | -------------------------------------------------------------------------------- /olmec/tables.md: -------------------------------------------------------------------------------- 1 | 2 | ## Adverbs and Conjunctions: 3 | ie. monadic and dyadic operators. 4 | 5 | symbol | adverb | desc | conjunction | desc 6 | --- | --- | --- | --- | --- 7 | & | _ | none | amp | compose functions or curry argument 8 | @ | _ | none | atop | compose functions 9 | / | areduce | reduce using verb | _ | none 10 | \ | ascan | scan using verb | _ | none 11 | ⍀ | abackscan | scan right-to-left using verb | _ | none 12 | ¨ | _ | none | rank | derive new verb with specified or borrowed rank 13 | 14 | 15 | 16 | ## monadic and dyadic Verbs: 17 | ie. unary and binary functions 18 | 19 | symbol | monadic | desc | dyadic | desc 20 | --- | --- | --- | --- | --- 21 | + | vid | identity | vplus | add 22 | - | vneg | negate/negative | vminus | subtract 23 | ¯ | vneg | negative/negate | vminus | subtract 24 | × | vsignum | sign of | vtimes | multiply 25 | * | vsignum | sign of | vtimes | multiply 26 | ÷ | vrecip | reciprocal | vdivide | divide 27 | ⋆ | _ | none | vpow | power 28 | ∣ | vabs | absolute value | vresidue | residue 29 | = | _ | none | veq | compare for equality 30 | ≠ | _ | none | vne | compare for inequality 31 | ⍴ | vshapeof | yield dimension vector | vreshape | new array with specified dimensions populated by elements from right array 32 | $ | vshapeof | yield dimension vector | vreshape | new array with specified dimensions populated by elements from right array 33 | # | vtally | number of items | _ | none 34 | ⍳ | viota | index generator | _ | none 35 | , | vravel | row-major-ordered vector of | vcat | catenate two arrays into vector 36 | ; | vprenul | ? | vlink | cat and enclose 37 | { | _ | none | vindexright | right is data and left is indices 38 | } | _ | none | vindexleft | left is data and right is indices 39 | ↑ | vhead | first element | vtake | first n elements 40 | ↓ | vbehead | all but the first | vdrop | all but first n elements 41 | / | _ | none | vcompress | select from right according to bools in left 42 | \ | _ | none | vexpand | accumulate from right or zeros according to bools in left 43 | ⊥ | _ | none | vbase | interpret vector right using base left 44 | ⊤ | _ | none | vencode | produce encoded vector of value right according to base left 45 | ⌽ | vreverse | reverse order of elements | vrotate | rotate through elements 46 | ⊂ | vconceal | encode array into simple scalar | _ | none 47 | ⊃ | vreveal | decode scalar into concealed array | _ | none 48 | ⍡ | vnoresult | for testing | vnoresultd | for testing 49 | → | vbranch | in del functions transfer to specified line | _ | none 50 | ⌀ | _ | none | _ | none 51 | 52 | 53 | -------------------------------------------------------------------------------- /olmec/verb.tab: -------------------------------------------------------------------------------- 1 | #include "verbs.h" 2 | 3 | #define nnone _ 4 | #define mnone _ 5 | #define dnone _ 6 | #define PRINT_VERB_TABLE(param,name, base, fnilad, fmonad, fdyad, f,g,h, m,l,r, mdesc, ddesc) \ 7 | base | fmonad | mdesc | fdyad | ddesc EOL 8 | VERBS_FOREACH(0,PRINT_VERB_TABLE) 9 | #undef nnone 10 | #undef mnone 11 | #undef dnone 12 | #undef PRINT_VERB_TABLE 13 | -------------------------------------------------------------------------------- /olmec/verb_private.h: -------------------------------------------------------------------------------- 1 | 2 | #define nnone 0 3 | #define mnone 0 4 | #define dnone 0 5 | #define DEFINE_VERB_IN_ENV(st, name, id, nil,mon,dy, f,g,h ,m,l,r, ...)\ 6 | v=malloc(sizeof*v); \ 7 | *v=(struct verb){newdata(PCHAR, id), nil,mon,dy, f,g,h, m,l,r}; \ 8 | def(st, newdata(PCHAR, id), vtab[VERB_##name] = cache(VERB, v),0); 9 | #undef nnone 10 | #undef mnone 11 | #undef dnone 12 | 13 | #define SCALAROP(a,func,w,op,v) \ 14 | scalarop(a,func,w,*#op,v) 15 | 16 | #define SCALARMONAD(func,w,op,v) \ 17 | scalarmonad(func,w,*#op,v) 18 | 19 | object scalarop(object a, dyad func, object w, char op, verb v); 20 | object vectorindexleft(object a, object w, verb v); 21 | -------------------------------------------------------------------------------- /olmec/verbs.h: -------------------------------------------------------------------------------- 1 | #ifndef VERBS_H_ 2 | #define VERBS_H_ 3 | #include "common.h" 4 | 5 | #define VERBS_FOREACH(param,_) \ 6 | /* name base nilad, monad dyad f g h mr lr rr mdesc ddesc*/ \ 7 | _(param,PLUS,'+', nnone, vid, vplus, 0, 0, 0, 0, 0, 0, \ 8 | identity, add) \ 9 | _(param,SUB, '-', nnone, vneg, vminus, 0, 0, 0, 0, 0, 0, \ 10 | negate/negative, subtract) \ 11 | _(param,SUB2,0x00af, nnone, vneg, vminus, 0, 0, 0, 0, 0, 0, \ 12 | negative/negate, subtract) \ 13 | _(param,MUL, 0x00d7, nnone, vsignum, vtimes, 0, 0, 0, 0, 0, 0, \ 14 | sign of, multiply) \ 15 | _(param,MUL2,'*', nnone, vsignum, vtimes, 0, 0, 0, 0, 0, 0, \ 16 | sign of, multiply) \ 17 | _(param,DIV, 0x00f7, nnone, vrecip, vdivide, 0, 0, 0, 0, 0, 0, \ 18 | reciprocal, divide) \ 19 | _(param,POW, 0x22c6/*alt-p*/, nnone, mnone, vpow, 0, 0, 0, 0, 0, 0, \ 20 | none, power)\ 21 | _(param,MOD, '|', nnone, vabs, vresidue, 0, 0, 0, 0, 0, 0, \ 22 | absolute value, residue) \ 23 | _(param,EQ, '=', nnone, mnone, veq, 0, 0, 0, 0, 0, 0, \ 24 | none, compare for equality) \ 25 | _(param,NE, 0x2260, nnone, mnone, vne, 0, 0, 0, 0, 0, 0, \ 26 | none, compare for inequality) \ 27 | _(param,RHO, 0x2374/*rho alt-r*/, nnone, vshapeof, vreshape, 0, 0, 0, 0, 0, 0, \ 28 | yield dimension vector, new array with specified dimensions populated by elements from right array) \ 29 | _(param,RHO2,'$', nnone, vshapeof, vreshape, 0, 0, 0, 0, 0, 0, \ 30 | yield dimension vector, new array with specified dimensions populated by elements from right array) \ 31 | _(param,TAL, '#', nnone, vtally, dnone, 0, 0, 0, 0, 0, 0, \ 32 | number of items, none) \ 33 | _(param,IOTA,0x2373/*iota alt-i*/, nnone, viota, dnone, 0, 0, 0, 0, 0, 0, \ 34 | index generator, none) \ 35 | _(param,CAT, ',', nnone, vravel, vcat, 0, 0, 0, 0, 0, 0, \ 36 | row-major-ordered vector of, catenate two arrays into vector) \ 37 | _(param,LINK,';', nnone, vprenul, vlink, 0, 0, 0, 0, 0, 0, \ 38 | ?, cat and enclose) \ 39 | _(param,INDR,'{', nnone, mnone, vindexright,0, 0, 0, 0, 0, 0, \ 40 | none, right is data and left is indices) \ 41 | _(param,INDL,'}', nnone, mnone, vindexleft, 0, 0, 0, 0, 0, 0, \ 42 | none, left is data and right is indices) \ 43 | _(param,TAKE,0x2191/*up alt-y*/, nnone, vhead, vtake, 0, 0, 0, 0, 1, 0, \ 44 | first element, first n elements) \ 45 | _(param,DROP,0x2193/*down alt-u*/, nnone, vbehead, vdrop, 0, 0, 0, 0, 0, 0, \ 46 | all but the first, all but first n elements) \ 47 | _(param,COMP,0x001f, nnone, mnone, vcompress, 0, 0, 0, 0, 0, 0, \ 48 | none, select from right according to bools in left) \ 49 | _(param,EXP, 0x001e, nnone, mnone, vexpand, 0, 0, 0, 0, 0, 0, \ 50 | none, accumulate from right or zeros according to bools in left) \ 51 | _(param,BASE,0x22a5/*alt-b*/, nnone, mnone, vbase, 0, 0, 0, 0, 0, 0, \ 52 | none, interpret vector right using base left) \ 53 | _(param,ENC, 0x22a4/*alt-n*/, nnone, mnone, vencode, 0, 0, 0, 0, 0, 0, \ 54 | none, produce encoded vector of value right according to base left) \ 55 | _(param,ROT, 0x233d/*alt-%*/, nnone, vreverse, vrotate, 0, 0, 0, 0, 0, 0, \ 56 | reverse order of elements, rotate through elements) \ 57 | _(param,CONC,0x2282/*alt-z*/, nnone, vconceal, dnone, 0, 0, 0, 0, 0, 0, \ 58 | encode array into simple scalar, none) \ 59 | _(param,REVL,0x2283/*alt-x*/, nnone, vreveal, dnone, 0, 0, 0, 0, 0, 0, \ 60 | decode scalar into concealed array, none) \ 61 | _(param,NONE,0x2361/*alt-q*/, nnone, vnoresult, vnoresultd,0, 0, 0, 0, 0, 0, \ 62 | for testing, for testing) \ 63 | _(param,BRNC,0x2192/*right alt-{*/, nnone, vbranch, dnone, 0, 0, 0, 0, 0, 0, \ 64 | in del functions transfer to specified line, none) \ 65 | _(param,NIL, 0x2300/*alt-U*/, vnil, mnone, dnone, 0, 0, 0, 0, 0, 0, \ 66 | none, none) \ 67 | /**/ 68 | 69 | struct verb { 70 | object id; 71 | nilad *nilad; 72 | monad *monad; 73 | dyad *dyad; 74 | object f,g,h; /* operator arguments */ 75 | int mr,lr,rr; /* monadic,left,right rank*/ 76 | }; 77 | 78 | #define nnone vnil 79 | #define mnone vid 80 | #define dnone vplus 81 | #define DECLARE_VERB_FUNCTIONS(param,name, base, fnilad, fmonad, fdyad, ...) \ 82 | nilad fnilad; \ 83 | monad fmonad; \ 84 | dyad fdyad; 85 | VERBS_FOREACH(0,DECLARE_VERB_FUNCTIONS) 86 | #undef nnone 87 | #undef mnone 88 | #undef dnone 89 | #undef DECLARE_VERB_FUNCTIONS 90 | 91 | 92 | #define VERBTAB_ENUM(param,name, ...) \ 93 | VERB_ ## name, 94 | enum { VERBS_FOREACH(0,VERBTAB_ENUM) VERB_NOOP }; 95 | extern object vtab[VERB_NOOP]; 96 | // yield verb from verbtab given enum short name 97 | #define VT(x) getptr(vtab[VERB_##x]) 98 | 99 | object ndel(verb v); 100 | object mdel(object w, verb v); 101 | object ddel(object a, object w, verb v); 102 | object ndfn(verb v); 103 | object mdfn(object w, verb v); 104 | object ddfn(object a, object w, verb v); 105 | 106 | void init_vb(symtab st); 107 | 108 | #endif 109 | -------------------------------------------------------------------------------- /olmec/xverb.c: -------------------------------------------------------------------------------- 1 | /* Xverbs are an abstraction to handle polymorphic symbols 2 | * such as '/' which can be a verb or an adverb. 3 | * 4 | * The verb and adverb must be defined with non-conflicting 5 | * identifiers. The xverb definition uses these two 6 | * definitions to select its components and then defines 7 | * the "superposition" under (presumably) one of the same 8 | * identifiers. 9 | */ 10 | 11 | #include 12 | #include 13 | 14 | #include "encoding.h" 15 | #include "symtab.h" 16 | #include "verbs.h" 17 | #include "xverb.h" 18 | 19 | void define_xverb_in_env(int id, int vrb, int adv, symtab st){ 20 | verb a,v; 21 | xverb x; 22 | symtab t; 23 | object *p; 24 | int n; 25 | 26 | p=(int[]){newdata(PCHAR, vrb)}; 27 | n=1; 28 | t=findsym(st, &p, &n, 0,0); 29 | DEBUG(3,"X%08x(%d,%d)\n", 30 | t->value, gettag(t->value), getval(t->value)); 31 | v=getptr(t->value); 32 | 33 | p=(int[]){newdata(PCHAR, adv)}; 34 | n=1; 35 | t=findsym(st, &p, &n, 0,0); 36 | DEBUG(3,"X%08x(%d,%d)\n", 37 | t->value, gettag(t->value), getval(t->value)); 38 | a=getptr(t->value); 39 | 40 | x=malloc(sizeof*x); 41 | *x=(struct xverb){newdata(PCHAR, id), v, a}; 42 | def(st, newdata(PCHAR, id), cache(XVERB, x),0); 43 | } 44 | 45 | #define DEFINE_XVERB_IN_ENV(env,id, vrb, adv) \ 46 | define_xverb_in_env(id, vrb, adv, env); 47 | 48 | void init_xverb(symtab env){ 49 | XVERBS_FOREACH(env,DEFINE_XVERB_IN_ENV) 50 | } 51 | 52 | -------------------------------------------------------------------------------- /olmec/xverb.h: -------------------------------------------------------------------------------- 1 | #ifndef XVERB_H_ 2 | #define XVERB_H_ 3 | #include "common.h" 4 | 5 | #define XVERBS_FOREACH(param,_) \ 6 | /*name verb adverb*/\ 7 | _(param,'/', 0x1f, '/') \ 8 | _(param,'\\', 0x1e, '\\') \ 9 | /**/ 10 | struct xverb { 11 | object id; 12 | verb verb; 13 | verb adverb; 14 | }; 15 | 16 | void init_xverb(symtab st); 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /ppnarg.h: -------------------------------------------------------------------------------- 1 | /* 2 | * The PP_NARG macro evaluates to the number of arguments that have been 3 | * passed to it. 4 | * 5 | * Laurent Deniau, "__VA_NARG__," 17 January 2006, (29 November 2007). 6 | */ 7 | #define PP_NARG(...) PP_NARG_(__VA_ARGS__,PP_RSEQ_N()) 8 | #define PP_NARG_(...) PP_ARG_N(__VA_ARGS__) 9 | 10 | #define PP_ARG_N( \ 11 | _1, _2, _3, _4, _5, _6, _7, _8, _9,_10, \ 12 | _11,_12,_13,_14,_15,_16,_17,_18,_19,_20, \ 13 | _21,_22,_23,_24,_25,_26,_27,_28,_29,_30, \ 14 | _31,_32,_33,_34,_35,_36,_37,_38,_39,_40, \ 15 | _41,_42,_43,_44,_45,_46,_47,_48,_49,_50, \ 16 | _51,_52,_53,_54,_55,_56,_57,_58,_59,_60, \ 17 | _61,_62,_63,N,...) N 18 | 19 | #define PP_RSEQ_N() \ 20 | 63,62,61,60, \ 21 | 59,58,57,56,55,54,53,52,51,50, \ 22 | 49,48,47,46,45,44,43,42,41,40, \ 23 | 39,38,37,36,35,34,33,32,31,30, \ 24 | 29,28,27,26,25,24,23,22,21,20, \ 25 | 19,18,17,16,15,14,13,12,11,10, \ 26 | 9,8,7,6,5,4,3,2,1,0 27 | -------------------------------------------------------------------------------- /tea.sh: -------------------------------------------------------------------------------- 1 | # tea.sh 2 | # attempt to re-write the math from my postscript program 3 | # which draws the Utah Teapot. 4 | # http://codegolf.stackexchange.com/a/25900/2381 5 | # some discussion: 6 | # https://groups.google.com/d/topic/comp.lang.apl/Y2nZZfWUo5w/discussion 7 | 8 | ./inca `cat ./teapot` <0{a)>~#a)/a 10 | v<((-2+b)@(;>(1+b){a)>~#a)/a 11 | h<:((x~y)>~#y)/y 12 | t<:((x~y)<~#y)/y 13 | n<:(((x<0{:.)"hy),(y~#y)/y 16 | w<:;(1<#y){(<:'xy);<:(x"w(0=~#y)/y);x"w(0!~#y)/y 17 | f<:(0{:,)"s'c>0{y 18 | q<;>0{p 19 | (q-1){v 20 | m0{a)>~#a)/a load patch data into p 37 | #v<((-2+b)@(;>(1+b){a)>~#a)/a load vertex data into v 38 | #h<:((x~y)>~#y)/y head of list y delimited by x 39 | #t<:((x~y)<~#y)/y tail of list y delimited by x 40 | #n<:(((x<0{:.)"hy),(y~#y)/y chop string 43 | #w<:;(1<#y){(<:'fy);<:('w(0=~#y)/y);'w(0!~#y)/y 'wy map func f over y 44 | #w<:;(1<#y){(<:'xy);<:(x"w(0=~#y)/y);x"w(0!~#y)/y x"wy map func x over y 45 | #f<:(0{:,)"s'c>0{y helper func: convert 1 vertex 46 | #q<;>0{p q is patch 0 indices 47 | #(q-1){v load vertices 48 | #r<'w(q-1){v r is: converted vertices of q, a 16x3 array 49 | #m0{p q is patch 0 indices 64 | #0!~#p a tail vector of p 65 | #u<'c>2{v u is chopped unboxed vertex line 2 66 | #i4{v 80 | #i0{a 92 | #c<((-1)@b>~#a)/a 93 | #d<;>(1+b){a 94 | #e<((-2+b)@d>~#a)/a 95 | #s<:(((0{x)!y)\y)+((0{x)=y)\(0!1+~#y).(1{x) 96 | #h<:(y<((~(#y)-1){y)) 97 | #i<:$,(((1~(0{:,)=y)>~#y)/y) 98 | #j<:$,((((1~x-(1~x<(0{:,)=y)=~#y)>~#y)-(1+1~x)>~#y)/y) 99 | #k<:$,(((1~x-(1~(x<(0{:,)=(y<'hy)))=~#y)<~#y)/y) 100 | #p<:$,y,(0=1+~<(5-(#((1~((0{:.)=y))<~#y)/y))) 101 | #q<:(1{y)+100000.0{y 102 | #v<>3{e 103 | #x<'q;$,((:. )"s'p'iv),0 104 | #y<'q;$,((:. )"s'p'jv),0 105 | #z<'q;$,((:. )"s'p'kv),0 106 | 107 | #f<>0{e 108 | #g<,((!(0{:,)=f)\f)+((0{:,)=f)\(0!1+~#f).(0{:;) 109 | #h<,((!(0{:.)=g)\g)+((0{:.)=g)\(0!1+~#g).(0{: ) 110 | #i<;$,h 111 | #f<>0{e 112 | #g<$,(:,;)"sf 113 | #h<$,(:. )"sg 114 | #i<;$,h 115 | 116 | #'hv 117 | #'p'iv 118 | 119 | #the variable a is set to the box-command-array of the argv[] strings 120 | # 0{a fetches argv[1] 121 | # >0{a unboxes it 122 | # ;>0{a executes the string, yielding the number 32 (from the teapot dataset) 123 | # b<;>0{a store the result as the variable b 124 | # #a is the length of a, or argc-1 125 | # ~#a is an iota vector from 0..argc-1-1 126 | # b>~#a yields a boolean vector, same length as a, with 1s in the first b slots 127 | # (-1)@b>~#a rotates the boolean vector down by 1, so 0 then b 1s then 0s filling out length of a 128 | # ((-1)@b>~#a)/a compress a with this boolean vector, yielding the patch data 129 | # c<((-1)@b>~#a)/a store the result as the variable c 130 | # (1+b){a fetch argv[b+1], the argv[] element with the number of vertices 131 | # >(1+b){a unbox it 132 | # ;>(1+b){a execute the string, yielding the number 306 133 | # d<;>(1+b){a store the result as the variable d 134 | # d>~#a yields a boolean vector, same length as a, with 1s in the first d slots 135 | # (-2+b)@d>~#a rotate down by b+2, so b+2 0s, then d 1s 136 | # ((-2+b)@d>~#a)/a compress a with this boolean vector, yielding the vertex data 137 | # f<>0{e f is the unboxed command-string of the first vertex 138 | # 1.4,0.0,2.4 139 | # (0{:,)=f yields a boolean vector the length of f, with 1s where the commas are in f 140 | # (!(0{:,)=f) boolean vector with 1s where f is not a comma 141 | # ((!(0{:,)=f)\f) expand f by this vector, yielding f with 0s where the commas were 142 | # ((0{:,)=f) boolean vector length of f, with 1s where the commas are in f (again) 143 | # (0!1+~#f) vector of 1s length of f 144 | # (0!1+~#f).(0{:;) vector of semicolons ;;;;;;;; length of f 145 | # ((0{:,)=f)\(0!1+~#f).(0{:;) vector with semicolons where the commas are in f and 0s elsewhere 146 | # ((!(0{:,)=f)\f) + ((0{:,)=f)\(0!1+~#f).(0{:;) yield f with commas replaced by semicolons 147 | # g<, ravel and store result as variable g 148 | # ((!(0{:.)=g)\g)+((0{:.)=g)\(0!1+~#g).(0{: ) yield g with periods replaced by spaces 149 | # h<, ravel and store result as variable h 150 | # i<;$,h execute h and store result in i, yielding 151 | # 1 4 152 | # 0 0 153 | # 2 4 154 | # repeating the process for vertex 1, yields incorrect results, since the negative 155 | # function in the y coordinate extends to the z coordinate as well. 156 | 157 | # substitution function s: 158 | # s<:((!(0{x)=y)\y)+((0{x)=y)\(0!1+~#y).(1{x) 159 | # replaces occurrences of 0{x in y with 1{x 160 | # g<$,(:,;)"sf 161 | 162 | -------------------------------------------------------------------------------- /teapot: -------------------------------------------------------------------------------- 1 | 32 2 | 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 3 | 4,17,18,19,8,20,21,22,12,23,24,25,16,26,27,28 4 | 19,29,30,31,22,32,33,34,25,35,36,37,28,38,39,40 5 | 31,41,42,1,34,43,44,5,37,45,46,9,40,47,48,13 6 | 13,14,15,16,49,50,51,52,53,54,55,56,57,58,59,60 7 | 16,26,27,28,52,61,62,63,56,64,65,66,60,67,68,69 8 | 28,38,39,40,63,70,71,72,66,73,74,75,69,76,77,78 9 | 40,47,48,13,72,79,80,49,75,81,82,53,78,83,84,57 10 | 57,58,59,60,85,86,87,88,89,90,91,92,93,94,95,96 11 | 60,67,68,69,88,97,98,99,92,100,101,102,96,103,104,105 12 | 69,76,77,78,99,106,107,108,102,109,110,111,105,112,113,114 13 | 78,83,84,57,108,115,116,85,111,117,118,89,114,119,120,93 14 | 121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136 15 | 124,137,138,121,128,139,140,125,132,141,142,129,136,143,144,133 16 | 133,134,135,136,145,146,147,148,149,150,151,152,69,153,154,155 17 | 136,143,144,133,148,156,157,145,152,158,159,149,155,160,161,69 18 | 162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177 19 | 165,178,179,162,169,180,181,166,173,182,183,170,177,184,185,174 20 | 174,175,176,177,186,187,188,189,190,191,192,193,194,195,196,197 21 | 177,184,185,174,189,198,199,186,193,200,201,190,197,202,203,194 22 | 204,204,204,204,207,208,209,210,211,211,211,211,212,213,214,215 23 | 204,204,204,204,210,217,218,219,211,211,211,211,215,220,221,222 24 | 204,204,204,204,219,224,225,226,211,211,211,211,222,227,228,229 25 | 204,204,204,204,226,230,231,207,211,211,211,211,229,232,233,212 26 | 212,213,214,215,234,235,236,237,238,239,240,241,242,243,244,245 27 | 215,220,221,222,237,246,247,248,241,249,250,251,245,252,253,254 28 | 222,227,228,229,248,255,256,257,251,258,259,260,254,261,262,263 29 | 229,232,233,212,257,264,265,234,260,266,267,238,263,268,269,242 30 | 270,270,270,270,279,280,281,282,275,276,277,278,271,272,273,274 31 | 270,270,270,270,282,289,290,291,278,286,287,288,274,283,284,285 32 | 270,270,270,270,291,298,299,300,288,295,296,297,285,292,293,294 33 | 270,270,270,270,300,305,306,279,297,303,304,275,294,301,302,271 34 | 306 35 | 1.4,0.0,2.4 36 | 1.4,-0.784,2.4 37 | 0.784,-1.4,2.4 38 | 0.0,-1.4,2.4 39 | 1.3375,0.0,2.53125 40 | 1.3375,-0.749,2.53125 41 | 0.749,-1.3375,2.53125 42 | 0.0,-1.3375,2.53125 43 | 1.4375,0.0,2.53125 44 | 1.4375,-0.805,2.53125 45 | 0.805,-1.4375,2.53125 46 | 0.0,-1.4375,2.53125 47 | 1.5,0.0,2.4 48 | 1.5,-0.84,2.4 49 | 0.84,-1.5,2.4 50 | 0.0,-1.5,2.4 51 | -0.784,-1.4,2.4 52 | -1.4,-0.784,2.4 53 | -1.4,0.0,2.4 54 | -0.749,-1.3375,2.53125 55 | -1.3375,-0.749,2.53125 56 | -1.3375,0.0,2.53125 57 | -0.805,-1.4375,2.53125 58 | -1.4375,-0.805,2.53125 59 | -1.4375,0.0,2.53125 60 | -0.84,-1.5,2.4 61 | -1.5,-0.84,2.4 62 | -1.5,0.0,2.4 63 | -1.4,0.784,2.4 64 | -0.784,1.4,2.4 65 | 0.0,1.4,2.4 66 | -1.3375,0.749,2.53125 67 | -0.749,1.3375,2.53125 68 | 0.0,1.3375,2.53125 69 | -1.4375,0.805,2.53125 70 | -0.805,1.4375,2.53125 71 | 0.0,1.4375,2.53125 72 | -1.5,0.84,2.4 73 | -0.84,1.5,2.4 74 | 0.0,1.5,2.4 75 | 0.784,1.4,2.4 76 | 1.4,0.784,2.4 77 | 0.749,1.3375,2.53125 78 | 1.3375,0.749,2.53125 79 | 0.805,1.4375,2.53125 80 | 1.4375,0.805,2.53125 81 | 0.84,1.5,2.4 82 | 1.5,0.84,2.4 83 | 1.75,0.0,1.875 84 | 1.75,-0.98,1.875 85 | 0.98,-1.75,1.875 86 | 0.0,-1.75,1.875 87 | 2.0,0.0,1.35 88 | 2.0,-1.12,1.35 89 | 1.12,-2.0,1.35 90 | 0.0,-2.0,1.35 91 | 2.0,0.0,0.9 92 | 2.0,-1.12,0.9 93 | 1.12,-2.0,0.9 94 | 0.0,-2.0,0.9 95 | -0.98,-1.75,1.875 96 | -1.75,-0.98,1.875 97 | -1.75,0.0,1.875 98 | -1.12,-2.0,1.35 99 | -2.0,-1.12,1.35 100 | -2.0,0.0,1.35 101 | -1.12,-2.0,0.9 102 | -2.0,-1.12,0.9 103 | -2.0,0.0,0.9 104 | -1.75,0.98,1.875 105 | -0.98,1.75,1.875 106 | 0.0,1.75,1.875 107 | -2.0,1.12,1.35 108 | -1.12,2.0,1.35 109 | 0.0,2.0,1.35 110 | -2.0,1.12,0.9 111 | -1.12,2.0,0.9 112 | 0.0,2.0,0.9 113 | 0.98,1.75,1.875 114 | 1.75,0.98,1.875 115 | 1.12,2.0,1.35 116 | 2.0,1.12,1.35 117 | 1.12,2.0,0.9 118 | 2.0,1.12,0.9 119 | 2.0,0.0,0.45 120 | 2.0,-1.12,0.45 121 | 1.12,-2.0,0.45 122 | 0.0,-2.0,0.45 123 | 1.5,0.0,0.225 124 | 1.5,-0.84,0.225 125 | 0.84,-1.5,0.225 126 | 0.0,-1.5,0.225 127 | 1.5,0.0,0.15 128 | 1.5,-0.84,0.15 129 | 0.84,-1.5,0.15 130 | 0.0,-1.5,0.15 131 | -1.12,-2.0,0.45 132 | -2.0,-1.12,0.45 133 | -2.0,0.0,0.45 134 | -0.84,-1.5,0.225 135 | -1.5,-0.84,0.225 136 | -1.5,0.0,0.225 137 | -0.84,-1.5,0.15 138 | -1.5,-0.84,0.15 139 | -1.5,0.0,0.15 140 | -2.0,1.12,0.45 141 | -1.12,2.0,0.45 142 | 0.0,2.0,0.45 143 | -1.5,0.84,0.225 144 | -0.84,1.5,0.225 145 | 0.0,1.5,0.225 146 | -1.5,0.84,0.15 147 | -0.84,1.5,0.15 148 | 0.0,1.5,0.15 149 | 1.12,2.0,0.45 150 | 2.0,1.12,0.45 151 | 0.84,1.5,0.225 152 | 1.5,0.84,0.225 153 | 0.84,1.5,0.15 154 | 1.5,0.84,0.15 155 | -1.6,0.0,2.025 156 | -1.6,-0.3,2.025 157 | -1.5,-0.3,2.25 158 | -1.5,0.0,2.25 159 | -2.3,0.0,2.025 160 | -2.3,-0.3,2.025 161 | -2.5,-0.3,2.25 162 | -2.5,0.0,2.25 163 | -2.7,0.0,2.025 164 | -2.7,-0.3,2.025 165 | -3.0,-0.3,2.25 166 | -3.0,0.0,2.25 167 | -2.7,0.0,1.8 168 | -2.7,-0.3,1.8 169 | -3.0,-0.3,1.8 170 | -3.0,0.0,1.8 171 | -1.5,0.3,2.25 172 | -1.6,0.3,2.025 173 | -2.5,0.3,2.25 174 | -2.3,0.3,2.025 175 | -3.0,0.3,2.25 176 | -2.7,0.3,2.025 177 | -3.0,0.3,1.8 178 | -2.7,0.3,1.8 179 | -2.7,0.0,1.575 180 | -2.7,-0.3,1.575 181 | -3.0,-0.3,1.35 182 | -3.0,0.0,1.35 183 | -2.5,0.0,1.125 184 | -2.5,-0.3,1.125 185 | -2.65,-0.3,0.9375 186 | -2.65,0.0,0.9375 187 | -2.0,-0.3,0.9 188 | -1.9,-0.3,0.6 189 | -1.9,0.0,0.6 190 | -3.0,0.3,1.35 191 | -2.7,0.3,1.575 192 | -2.65,0.3,0.9375 193 | -2.5,0.3,1.125 194 | -1.9,0.3,0.6 195 | -2.0,0.3,0.9 196 | 1.7,0.0,1.425 197 | 1.7,-0.66,1.425 198 | 1.7,-0.66,0.6 199 | 1.7,0.0,0.6 200 | 2.6,0.0,1.425 201 | 2.6,-0.66,1.425 202 | 3.1,-0.66,0.825 203 | 3.1,0.0,0.825 204 | 2.3,0.0,2.1 205 | 2.3,-0.25,2.1 206 | 2.4,-0.25,2.025 207 | 2.4,0.0,2.025 208 | 2.7,0.0,2.4 209 | 2.7,-0.25,2.4 210 | 3.3,-0.25,2.4 211 | 3.3,0.0,2.4 212 | 1.7,0.66,0.6 213 | 1.7,0.66,1.425 214 | 3.1,0.66,0.825 215 | 2.6,0.66,1.425 216 | 2.4,0.25,2.025 217 | 2.3,0.25,2.1 218 | 3.3,0.25,2.4 219 | 2.7,0.25,2.4 220 | 2.8,0.0,2.475 221 | 2.8,-0.25,2.475 222 | 3.525,-0.25,2.49375 223 | 3.525,0.0,2.49375 224 | 2.9,0.0,2.475 225 | 2.9,-0.15,2.475 226 | 3.45,-0.15,2.5125 227 | 3.45,0.0,2.5125 228 | 2.8,0.0,2.4 229 | 2.8,-0.15,2.4 230 | 3.2,-0.15,2.4 231 | 3.2,0.0,2.4 232 | 3.525,0.25,2.49375 233 | 2.8,0.25,2.475 234 | 3.45,0.15,2.5125 235 | 2.9,0.15,2.475 236 | 3.2,0.15,2.4 237 | 2.8,0.15,2.4 238 | 0.0,0.0,3.15 239 | 0.0,-0.002,3.15 240 | 0.002,0.0,3.15 241 | 0.8,0.0,3.15 242 | 0.8,-0.45,3.15 243 | 0.45,-0.8,3.15 244 | 0.0,-0.8,3.15 245 | 0.0,0.0,2.85 246 | 0.2,0.0,2.7 247 | 0.2,-0.112,2.7 248 | 0.112,-0.2,2.7 249 | 0.0,-0.2,2.7 250 | -0.002,0.0,3.15 251 | -0.45,-0.8,3.15 252 | -0.8,-0.45,3.15 253 | -0.8,0.0,3.15 254 | -0.112,-0.2,2.7 255 | -0.2,-0.112,2.7 256 | -0.2,0.0,2.7 257 | 0.0,0.002,3.15 258 | -0.8,0.45,3.15 259 | -0.45,0.8,3.15 260 | 0.0,0.8,3.15 261 | -0.2,0.112,2.7 262 | -0.112,0.2,2.7 263 | 0.0,0.2,2.7 264 | 0.45,0.8,3.15 265 | 0.8,0.45,3.15 266 | 0.112,0.2,2.7 267 | 0.2,0.112,2.7 268 | 0.4,0.0,2.55 269 | 0.4,-0.224,2.55 270 | 0.224,-0.4,2.55 271 | 0.0,-0.4,2.55 272 | 1.3,0.0,2.55 273 | 1.3,-0.728,2.55 274 | 0.728,-1.3,2.55 275 | 0.0,-1.3,2.55 276 | 1.3,0.0,2.4 277 | 1.3,-0.728,2.4 278 | 0.728,-1.3,2.4 279 | 0.0,-1.3,2.4 280 | -0.224,-0.4,2.55 281 | -0.4,-0.224,2.55 282 | -0.4,0.0,2.55 283 | -0.728,-1.3,2.55 284 | -1.3,-0.728,2.55 285 | -1.3,0.0,2.55 286 | -0.728,-1.3,2.4 287 | -1.3,-0.728,2.4 288 | -1.3,0.0,2.4 289 | -0.4,0.224,2.55 290 | -0.224,0.4,2.55 291 | 0.0,0.4,2.55 292 | -1.3,0.728,2.55 293 | -0.728,1.3,2.55 294 | 0.0,1.3,2.55 295 | -1.3,0.728,2.4 296 | -0.728,1.3,2.4 297 | 0.0,1.3,2.4 298 | 0.224,0.4,2.55 299 | 0.4,0.224,2.55 300 | 0.728,1.3,2.55 301 | 1.3,0.728,2.55 302 | 0.728,1.3,2.4 303 | 1.3,0.728,2.4 304 | 0.0,0.0,0.0 305 | 1.5,0.0,0.15 306 | 1.5,0.84,0.15 307 | 0.84,1.5,0.15 308 | 0.0,1.5,0.15 309 | 1.5,0.0,0.075 310 | 1.5,0.84,0.075 311 | 0.84,1.5,0.075 312 | 0.0,1.5,0.075 313 | 1.425,0.0,0.0 314 | 1.425,0.798,0.0 315 | 0.798,1.425,0.0 316 | 0.0,1.425,0.0 317 | -0.84,1.5,0.15 318 | -1.5,0.84,0.15 319 | -1.5,0.0,0.15 320 | -0.84,1.5,0.075 321 | -1.5,0.84,0.075 322 | -1.5,0.0,0.075 323 | -0.798,1.425,0.0 324 | -1.425,0.798,0.0 325 | -1.425,0.0,0.0 326 | -1.5,-0.84,0.15 327 | -0.84,-1.5,0.15 328 | 0.0,-1.5,0.15 329 | -1.5,-0.84,0.075 330 | -0.84,-1.5,0.075 331 | 0.0,-1.5,0.075 332 | -1.425,-0.798,0.0 333 | -0.798,-1.425,0.0 334 | 0.0,-1.425,0.0 335 | 0.84,-1.5,0.15 336 | 1.5,-0.84,0.15 337 | 0.84,-1.5,0.075 338 | 1.5,-0.84,0.075 339 | 0.798,-1.425,0.0 340 | 1.425,-0.798,0.0 341 | --------------------------------------------------------------------------------