├── .gitignore ├── Makefile ├── README.md ├── examples ├── hello.lviv ├── qsort.lviv ├── quine.lviv └── test.lviv └── src ├── lviv-env.scm ├── lviv-exceptions.scm ├── lviv-funcalls.scm ├── lviv-misc.scm ├── lviv-prelude.scm ├── lviv-repl.scm ├── lviv-specforms.scm ├── lviv-stack.scm ├── lviv-state.scm ├── lviv-symbols.scm ├── lviv-tests.scm └── lviv.scm /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw? 2 | build 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for lviv 2 | # 3 | # Copyright (c) 2011 Riad S. Wahby 4 | # 5 | # Permission is hereby granted, free of charge, to any person obtaining a copy 6 | # of this software and associated documentation files (the "Software"), to deal 7 | # in the Software without restriction, including without limitation the rights 8 | # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | # copies of the Software, and to permit persons to whom the Software is 10 | # furnished to do so, subject to the following conditions: 11 | # 12 | # The above copyright notice and this permission notice shall be included in 13 | # all copies or substantial portions of the Software. 14 | # 15 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | # THE SOFTWARE. 22 | 23 | # this might seem strange, but it gives us the files in the correct order 24 | # for debug invocation 25 | DEBUGFILES = $(shell grep include src/lviv.scm | grep -v \; | cut -d \" -f 2 | sed 's/^/src\//') 26 | SRCFILES = src/lviv.scm $(DEBUGFILES) 27 | ARGS = - 28 | .PHONY: all run runtest clean lviv test debug prof profrun 29 | 30 | all: lviv test 31 | 32 | # override ARGS on the commandline: 33 | # make ARGS="examples/hello.lviv -" run 34 | run: 35 | gsi src/lviv.scm $(ARGS) 36 | 37 | runtest: 38 | gsi src/lviv.scm examples/test.lviv examples/hello.lviv 39 | 40 | clean: 41 | rm -rf build 42 | 43 | lviv: build/lviv 44 | 45 | test: lviv 46 | build/lviv examples/test.lviv examples/hello.lviv 47 | 48 | # run gsi on the source files, but do not run the repl 49 | debug: 50 | gsi $(DEBUGFILES) - 51 | 52 | # build lviv executable with profiling and coverage tests 53 | prof: build/lviv-prof 54 | 55 | # this will profile a long run of recursive calls to get an idea of the hot spots 56 | profrun: prof 57 | cd build && echo '((nop) (1 + *n *upToN) 3 pick *n >= if) (*n) lambda *upToN define 1 100000 upToN' | ./lviv-prof && gprof ./lviv-prof > gprof.out 58 | cd build && gcov lviv-prof 59 | 60 | # real targets from here down 61 | 62 | build/lviv: $(SRCFILES) 63 | mkdir -p build 64 | GAMBC_CC_VERBOSE=yes gsc -warnings -o $@ -exe $< 65 | strip $@ 66 | 67 | build/lviv-prof: $(SRCFILES) 68 | mkdir -p build 69 | GAMBC_CC_VERBOSE=yes gsc -warnings -track-scheme -link $< 70 | mv src/lviv.c build/lviv-prof.c 71 | mv src/lviv_.c build/lviv-prof_.c 72 | cd build && gcc -o $(notdir $@) -fprofile-arcs -ftest-coverage -pg lviv-prof.c lviv-prof_.c -lgambc -lm -lutil -ldl -pg 73 | 74 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lviv 2 | 3 | lviv is a functional stack-based programming language. Or maybe it's just a fancy programmable calculator. 4 | 5 | lviv is written in Scheme. It's possible that it will work in a bunch of different Scheme environments, but I use Gambit-C Scheme v4.6.1 for development, so I don't guarantee that it'll work in any other scheme interpreter. 6 | 7 | lviv is an experiment in hybrid functional-stack language design. The idea was to have a very regular syntax that was 100% compatible with postfix notation without requiring a modal interpreter (i.e., no ": ... ;" stuff like in FORTH; this means that everything, including `lambda`, `define`, `if`, `let`, et cetera, uses postfix notation) and with a minimal number of special forms. The original impetus came from a paper I read about how tail call optimization happens very naturally when the machine model is stack based. Naturally, lviv supports tail call optimization. 8 | 9 | The name comes from the city of Lviv, where Jan Lukasiewicz was born. Lukasiewicz invented prefix or "Polish" notation to simplify the syntax of sentential logic; later, Burks, Warren, and Wright (and even later Bauer and Dijkstra) proposed postfix, or "reverse Polish" notation as a good fit for stack based machines. 10 | 11 | ## Examples 12 | 13 | Let's look at some example code so you know what you're getting yourself into. 14 | 15 | #### square 16 | 17 | > (*x dup *) (*x) lambda *square define 18 | > 5 square 19 | 25 20 | 21 | #### factorial 22 | 23 | > ((1) (*x dup 1 - *fact *) *x 0 eq? if) (*x) lambda *fact define 24 | > 5 fact 25 | 120 26 | 27 | #### fibonacci 28 | 29 | > ((swap drop) (dup 3 roll + *x 1 - *fibHlp) *x 0 eq? if) (*x) lambda *fibHlp define 30 | > ((0) (0 1 *x 1 - *fibHlp) *x 1 < if) (*x) lambda *fib define 31 | > 5 fib 32 | 5 33 | > 15 fib 34 | 610 35 | > 25 fib 36 | 75025 37 | 38 | We could also do this with the helper defined inside the parent environment: 39 | 40 | > ( ((swap drop) (dup 3 roll + **x 1 - **fibHlp) **x 0 eq? if) (**x) lambda 41 | **fibHlp define (0) (0 1 *x 1 - **fibHlp) *x 1 < if ) (*x) lambda 42 | *fib define 43 | > 25 fib 44 | 75025 45 | 46 | Note that the `x` in the scope of the inner lambda needs to be double-quoted (`**x`) because we want its interpolation delayed until the inner lambda executes. In general, the number of stars is *parenDepth*-*ifParenDepth* if you want the variable's value, or *parenDepth*-*ifParenDepth*+1 if you want the literal name. 47 | 48 | #### Accumulator 49 | 50 | We define two functions, showA and incA, that show and increment the value of an accumulator, respectively. Note that both functions close over a private environment. 51 | 52 | > ( (**n) () lambda (1 **n + **nref define) () lambda 53 | *&n **nref define 1 **n define ) () lambda apply 54 | *incA define *readA define 55 | > readA 56 | 1 57 | > drop incA incA incA readA 58 | 4 59 | > drop incA incA incA readA 60 | 7 61 | 62 | Note how here we quote `*&n` to delay its binding until it is evaluated in the environment of the outermost lambda. 63 | 64 | ## Building and running lviv 65 | 66 | The Makefile that comes with lviv should do almost everything you need. 67 | 68 | If you just want to run lviv, `make run` will run lviv with gsi. You can pass arguments by overriding the `ARGS` variable in your make invocation (e.g., `make ARGS="foo.lviv" run`), or you can just run gsi directly yourself. `make runtest` will run the test files in the examples directory using gsi. 69 | 70 | The `lviv` target builds a self-contained lviv executable. `test` takes this executable and runs the tests from the examples directory. The default target, `all`, is equivalent to `make lviv test`. 71 | 72 | The `debug` target invokes gsi with the lviv source files, but leaves you at the Scheme REPL rather than invoking the lviv REPL. This lets you examine the behavior of the interpreter directly. 73 | 74 | Finally, there are the profiling targets, `prof` and `profrun`, which build the executable with profiling enabled and run this profiling executable on some dummy code, respectively. 75 | 76 | ## Basics 77 | 78 | If you've used an HP calculator, you're probably familiar with how RPN works. Expressions are entered by pushing entries onto a stack and applying operators to the stack. Operators pop a defined number of operands off the stack, perform a computation, and push the result back onto the stack. For example, 79 | 80 | > 1 81 | 1 82 | > 2 83 | 1 84 | 2 85 | > + 86 | 3 87 | > 2 * 88 | 6 89 | > 6 * sqrt 90 | 6 91 | 92 | ### Order of application 93 | 94 | RPN operations are applied in left-to-right order: prefix and postfix notation are related by simply translating the operator from the beginning to the end of the expression. `- 6 1` becomes `6 1 -`, and both should equal 5. This seems somewhat logical for a calculator, since it matches our intuition for the basic noncommutative arithmetic operations. 95 | 96 | At times, this order of operations can be clunky. Thus, any primitive or lambda can be applied in reverse by prepending it with `:`. Thus, `6 1 -` yields `5`, and `6 1 :-` gives `-5`. 97 | 98 | ## Stack operations 99 | 100 | The contents of the stack often represent most or all of the program's state. Thus, primitive stack operations underly most higher level operations in lviv. 101 | 102 | There are no explicit "push" and "pop" operations; values are pushed as they're entered, and popped as needed for function application. 103 | 104 | ### `swap` 105 | 106 | Swap the 0th and 1st entry in the stack. 107 | 108 | > 1 2 109 | 1 110 | 2 111 | > swap 112 | 2 113 | 1 114 | 115 | ### `drop`, ` dropN`, `clear` 116 | 117 | `drop` removes the 0th element from the stack. `dropN` pops the 0th entry off the stack, and then drops that number of remaining entries. `clear` drops all entries from the stack. 118 | 119 | > 1 120 | 1 121 | > drop 122 | > 1 3 2 123 | 1 124 | 3 125 | 2 126 | > dropN 127 | > 128 | 129 | ### ` roll`, ` unroll` 130 | 131 | `roll` and `unroll` pop the 0th element off the stack and perform a circular shift upwards (`roll`) or downwards (`unroll`) involving *n* elements. 132 | 133 | > 1 2 3 4 5 6 134 | 1 135 | 2 136 | 3 137 | 4 138 | 5 139 | 6 140 | > 3 roll 141 | 1 142 | 2 143 | 3 144 | 5 145 | 6 146 | 4 147 | > unroll 148 | 1 149 | 6 150 | 2 151 | 3 152 | 5 153 | 154 | ### `dup`, ` dupN` 155 | 156 | `dup` pushes a copy of the 0th element onto the stack. `dupN` pops the 0th argument off the stack, and pushes copies of the top *n* elements onto the stack. 157 | 158 | > 1 2 3 dup 159 | 1 160 | 2 161 | 3 162 | 3 163 | > 3 dupN 164 | 1 165 | 2 166 | 3 167 | 3 168 | 2 169 | 3 170 | 3 171 | 172 | ### `over`, ` pick` 173 | 174 | `pick` pops the 0th element off the stack, then pushes a copy of the *nth* element onto the stack. `over` is equivalent to `2 pick`. 175 | 176 | > 1 2 3 177 | 1 178 | 2 179 | 3 180 | > over 181 | 1 182 | 2 183 | 3 184 | 2 185 | > 2 pick 186 | 1 187 | 2 188 | 3 189 | 2 190 | 3 191 | 192 | ### `depth` 193 | 194 | Pushes the depth of the stack prior to the `depth` operation onto the stack. 195 | 196 | > 0 197 | 0 198 | > depth 199 | 0 200 | 1 201 | > 2 dropN depth 202 | 0 203 | 204 | ### ` swapIf`, ` swapUnless`, ` dropIf`, ` dropUnless` 205 | 206 | `swapIf` pops the 0th element off the stack, and then performs a `swap` if that element was `#t`. `swapUnless` does the same for `#f`. `dropIf` and `dropUnless` behave similarly. Note that these operations only accept the boolean values `#t` or `#f`; other values result in a type error. 207 | 208 | > 1 2 #t swapIf drop 209 | 2 210 | > clear 211 | > 1 2 #f swapUnless - 212 | -1 213 | 214 | ### `nop` 215 | 216 | Does nothing. It is useful for operations that conditionally modify the stack. 217 | 218 | ### `env` 219 | 220 | Shows the current environment. It can be useful for debugging. 221 | 222 | ### `stk` 223 | 224 | Print the current stack. This is useful during batch execution. 225 | 226 | ### Mathematical operations 227 | 228 | All mathematical functions available in Scheme can be bound as primitives in lviv. These should be bound in the prelude when I get around to it :) 229 | 230 | ## Functional syntax 231 | 232 | lviv syntax will be somewhat familiar to LISP programmers. 233 | 234 | ### Lists 235 | 236 | Formally, a list is defined either as the empty list (`nil` or `()`), or as the result of the `cons` operation on an element and a list. An element is anything that can be a stack entry. 237 | 238 | `car` and `cdr` produce the element and the trailing list, respectively. `uncons` pops a list off the stack and pushes on the cdr, then the car. 239 | 240 | `(a (b c) d)`-like syntax can be used to create a list directly. 241 | 242 | > nil 243 | () 244 | > 1 :cons 245 | (1) 246 | > 2 :cons 247 | (2 1) 248 | > (3 4) append 249 | (2 1 3 4) 250 | > uncons 251 | (1 3 4) 252 | 2 253 | > :cons 254 | (2 1 3 4) 255 | > cdr 256 | (1 3 4) 257 | > car 258 | 1 259 | 260 | ### Tuples 261 | 262 | Tuples in lviv can also be constructed using `cons`. A tuple is simply an unterminated list. 263 | 264 | > *a *b cons 265 | (a . b) 266 | > *a *b cons cons 267 | ((a . b) a . b) 268 | > (*c *d . (*e . *f)) 269 | ((a . b) a . b) 270 | (c d e . f) 271 | 272 | ### Environment bindings 273 | 274 | #### ` define` 275 | 276 | `define` binds the identifier in the 0th position on the stack with the value in the 1st. If the identifier is a static symbol (&foo), the binding is placed in the attached environment. Otherwise, the binding is placed in the current environment. 277 | 278 | Identifiers can contain alphanumerics or any of `! $ % & * + - . / : < = > ? @ ^ _ ~`, but must begin with a character that cannot begin a number and is not otherwise reserved (i.e., any valid character other than `. + - & * !`). 279 | 280 | When a bound variable is placed on the stack, it is immediately replaced by its value. To invoke the identifier and force delayed binding, the `&` or `*` sigil can be used. The `&` sigil indicates that the variable is statically bound when pushed on the stack, whereas the `*` prefix simply places the identifier on the stack, leaving its binding to an environment until evaluation. 281 | 282 | > 1 *z define 283 | > 2 z 284 | 2 285 | 1 286 | > - 287 | 1 288 | > (&z +) cons thunk 289 | # )> 290 | > 2 *z define 291 | # 292 | > apply 293 | 3 294 | > (*z &z +) (*z) lambda apply 295 | 5 296 | 297 | #### ` undef`, ` undefLocal` 298 | 299 | `undef` is used to delete a binding from the environment. If the identifier is a static variable, the binding is searched starting in the attached environment and removed if found. Otherwise, the search begins in the current environment. 300 | 301 | Note that `undef` will search from the present environment level all the way up to the top. To prevent the search from extending into the parent of the starting search environment, use `undefLocal` instead. 302 | 303 | #### Scope 304 | 305 | Static sybols (invoked with `&`) bind immediately to the enclosing environment when the symbol is put on the stack. The static binding element carries a reference to its environment with it, so it can be properly dereferenced even when enclosed in another environment (e.g., a let or lambda) where its name is shadowed. 306 | 307 | Unbound identifiers (invoked with `*`) have no binding when they are put on the stack. Instead, they are bound when they are evaluated. Since lambdas and lets carry an environment with them, unbound identifiers are statically scoped once bound inside these elements. However, an unbound identifier inside a thunk takes its value from the enclosing environment at the time of application. This effectively allows unbound identifiers to be used as static variables (inside lambdas and lets) or dynamic variables (inside thunks). 308 | 309 | ### `eval` and `apply` 310 | 311 | `eval` evaluates the top entry on the stack. Variables are dereferenced, but most other expressions are idempotent. This is probably nonintutive, so a bit of explanation is in order. 312 | 313 | In LISP, evaluating a list results in a computation as if that list were typed in as code. In lviv, lists do not represent a fundamental unit of computation, so evaluating a list merely dereferences the enclosed variables. Similarly, application in LISP combines a list of arguments with a function. In lviv, all application involves an element interacting with the stack. If the element is a function, its application involves popping arguments and pushing results. Otherwise, the application of an element to the stack simply results in that element being pushed onto the stack. 314 | 315 | To cause its contents to be computed as if entered at the prompt, a list must be turned into a thunk and then applied using `apply`. Alternatively, it can be turned into a lambda with an empty argument list and then applied. The fundamental difference between a lambda and a thunk is that the latter is bound to an environment when applied, whereas the former is bound to an environment when created. 316 | 317 | > 1 eval 318 | 1 319 | > *a define 320 | > *a 321 | a 322 | > eval 323 | 1 324 | > (*a 2) cons 325 | (1 a 2) 326 | > 4 *a define 327 | (1 a 2) 328 | > eval 329 | (1 4 2) 330 | 331 | Other than when working on thunks, `apply` takes the top element off the list and applies it as it just typed into the REPL. Thus, the semantics of `apply` are not exactly the same as in LISP: in lviv, `apply` applies the top element on the stack to the stack. Most elements are idempotent through such application (i.e., applying 1 to the stack just puts 1 on the stack); lambdas, primitives, and thunks result in computation when applied to the stack. 332 | 333 | ...continued from above... 334 | ( 1 4 2 ) 335 | > 1 apply 336 | ( 1 4 2 ) 337 | 1 338 | > *:cons 339 | ( 1 4 2 ) 340 | 1 341 | :cons 342 | > apply 343 | ( 1 4 2 ) 344 | 1 345 | :cons 346 | > eval 347 | ( 1 4 2 ) 348 | 1 349 | # 350 | > apply 351 | ( 1 1 4 2 ) 352 | 353 | ### `thunk` 354 | 355 | lviv represents delayed computations using thunks. The `apply` function unwraps a thunk and evaluates it as if its contents were typed into the REPL. Thunks are idempotent through `eval`, which means that their bindings are delayed until they are applied. This means that `thunk`s can introduce dynamic scoping: if a thunk is stored in a variable, it can be retrieved by two different functions. When applied, its scope is determined by the function it is called in, not by its definition scope. 356 | 357 | > (1 *z +) thunk 358 | # )> 359 | > eval 360 | # 361 | > dup 2 *z define apply 362 | # 363 | 3 364 | > 15 + *z define apply 365 | 19 366 | 367 | ### `unthunk` 368 | 369 | A thunk on the stack can be turned back into its constituent code with `unthunk`. 370 | 371 | > (1 2 +) thunk 372 | # )> 373 | > dup apply 374 | # )> 375 | 3 376 | > swap unthunk (3 *) append thunk 377 | 3 378 | # 3 # )> 379 | > apply 380 | 3 381 | 9 382 | 383 | ### ` primitive` 384 | 385 | `primitive` is used to bind an underlying scheme operation into a lviv element. For example, 386 | 387 | > 2 *expt primitive 388 | # 389 | > 2 3 3 roll 390 | 2 391 | 3 392 | # 393 | > apply 394 | 8 395 | > 2 *expt primitive *expt define 2 expt 396 | 64 397 | 398 | ### ` lambda` 399 | 400 | `lambda` combines a delayed computation and a binding list into a function. Positional identifiers cannot be used with a `lambda`. 401 | 402 | Binding lists map variables inside the thunk to positions on the stack at application time. 403 | 404 | > *x 405 | x 406 | > (1 +) cons 407 | ( x 1 # ) 408 | > (*y *) append 409 | ( x 1 # y # ) 410 | > (*x *y) lambda *xyfunc define 411 | > 2 1 412 | 2 413 | 1 414 | > xyfunc 415 | 3 416 | > 2 *xyfunc eval 417 | 3 418 | 2 419 | # y # ) ( x y )> 420 | > apply 421 | 8 422 | 423 | The above lambda is equivalent to 424 | 425 | > (swap 1 + swap *) thunk 426 | # 1 # # # )> 427 | > 2 1 3 roll 428 | 2 429 | 1 430 | # 1 # # # )> 431 | > apply 432 | 3 433 | 434 | ### ` unlambda` 435 | 436 | Like `unthunk`, `unlambda` lets you break open a lambda and do stuff to it. 437 | 438 | > (1 *a +) (*a) lambda dup 439 | # ) ( a )> 440 | # ) ( a )> 441 | > 3 swap apply 442 | # ) ( a )> 443 | 4 444 | > swap unlambda 445 | 4 446 | ( 1 a # ) 447 | ( a ) 448 | > (*b) append swap 449 | 4 450 | ( a b ) 451 | ( 1 a # ) 452 | > (*b *) append swap lambda 453 | 4 454 | # b # ) ( a b )> 455 | > 5 swap apply 456 | 25 457 | 458 | ### ` let` 459 | 460 | `let` is similar to `lambda`: it combines a delayed computation and a binding list. `let` is evaluated immediately and the result of the evaluation is pushed onto the stack. 461 | 462 | > 2 *a define 463 | > (&a *a *b + *) ( (*a . 1) (*b . (*a &a +)) ) let 464 | 8 465 | > 6 *z define 466 | 8 467 | > (*z +) cons 468 | ( 8 z # ) 469 | > (*a *) append ( (*a . 1) ) let 470 | 14 471 | 472 | ### ` if`, ` unless` 473 | 474 | `if` is actually just a short way of saying `swapUnless drop thunk apply`. 475 | 476 | > 1 (nop) (0 /) #t if 477 | 1 478 | > (3 -) (3 +) #f if 479 | 4 480 | > (3 -) (3 +) #t swapUnless drop thunk apply 481 | 1 482 | > ((2) (1) #t if) (0) #t if + 483 | 3 484 | 485 | The first example above illustrates that only one of the consequent or alternative is applied as one would expect. 486 | 487 | `unless` is equivalent to `swapIf drop thunk apply`. 488 | 489 | ## Other operations 490 | 491 | ### `tstk`, `dtstk`, `untstk`, and `rtstk` 492 | 493 | `tstk` moves aside the present stack and replaces it with an empty temporary stack. `untstk` removes the temporary stack and restores the previous one. `rtstk` pops the 0th value off the temporary stack, restores the previous stack, and pushes this value. 494 | 495 | `dtstk` is like tstk except that it duplicates the present stack into the new temporary one. 496 | 497 | `tstk` calls can be nested; each `untstk` or `rtstk` ascends one level of nesting. 498 | 499 | ### `lstk`, `unlstk` 500 | 501 | `lstk` turns the stack into a list, which becomes the only element on the stack. 502 | 503 | `unlstk` takes the 0th element of the stack, which must be a list, and expands it onto 504 | the stack. 505 | 506 | `lstk unlstk` is idempotent. 507 | 508 | This can be used to return the entire contents of a temporary stack to its predecessor using rtstk. 509 | 510 | ### exception handling *NOT YET IMPLEMENTED* 511 | 512 | ## License 513 | 514 | Permission is hereby granted, free of charge, to any person obtaining a copy 515 | of this software and associated documentation files (the "Software"), to deal 516 | in the Software without restriction, including without limitation the rights 517 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 518 | copies of the Software, and to permit persons to whom the Software is 519 | furnished to do so, subject to the following conditions: 520 | 521 | The above copyright notice and this permission notice shall be included in 522 | all copies or substantial portions of the Software. 523 | 524 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 525 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 526 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 527 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 528 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 529 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 530 | THE SOFTWARE. 531 | 532 | Copyright (c) 2011 Riad S. Wahby 533 | 534 | -------------------------------------------------------------------------------- /examples/hello.lviv: -------------------------------------------------------------------------------- 1 | (*x dup *) (*x) lambda *square define 2 | 5 square 3 | ; expect 25 here 4 | stk clear 5 | 6 | ((1) (*x dup 1 - *fact *) *x 0 eq? if) (*x) lambda *fact define 7 | 5 fact 8 | ; expect 120 here 9 | stk clear 10 | 11 | ((swap drop) (dup 3 roll + *x 1 - *fibHlp) *x 0 eq? if) (*x) lambda *fibHlp define 12 | ((0) (0 1 *x 1 - *fibHlp) *x 1 < if) (*x) lambda *fib define 13 | 25 fib 14 | ; expect 75025 15 | stk clear 16 | 17 | ( ((swap drop) (dup 3 roll + **x 1 - **fibHlp) **x 0 eq? if) (**x) lambda 18 | **fibHlp define (0) (0 1 *x 1 - **fibHlp) *x 1 < if ) (*x) lambda 19 | *fib define 20 | 25 fib 21 | ; expect 75025 22 | stk clear 23 | *fibHlp undef 24 | 25 | ( (**n) () lambda (1 **n + **nref define) () lambda 26 | *&n **nref define 1 **n define ) () lambda apply 27 | *incA define *readA define 28 | readA 29 | ; expect 1 30 | stk clear 31 | incA incA incA incA incA readA 32 | ; expect 6 33 | stk clear 34 | 35 | 0 *newline primitive apply drop 36 | "Should have printed out 25 120 75025 75025 1 6" 37 | stk clear 38 | 0 *newline primitive apply drop 39 | ; this program should output 40 | ; 25 41 | ; 120 42 | ; 75025 43 | ; 75025 44 | ; 1 45 | ; 6 46 | -------------------------------------------------------------------------------- /examples/qsort.lviv: -------------------------------------------------------------------------------- 1 | ; qsort.lviv 2 | ; quicksort implemented in lviv 3 | 4 | ; filter2 5 | ; given a predicate in slot 0 and a list in slot 1 6 | ; filter the list into two lists, one for which the 7 | ; predicate is true and one for which it is false 8 | ( (*tList *fList) ; if the list is null, return the true and false lists 9 | (*lList uncons (*tList cons *fList) ; otherwise, take the first element, cons it to tlist 10 | (*fList cons *tList swap) ; or flist as appropriate 11 | 3 pick *pred apply if ; (test whether to cons to tList or fList) 12 | 3 roll ***pred eval *filt2Hlp) ; then get the stack back in order and call again 13 | *lList null? if ) ; (test whether list is null) 14 | (*tList *fList *lList *pred) lambda *filt2Hlp define 15 | 16 | ( () () *lList **pred eval *filt2Hlp ) ; call the helper function with empty tList and fList 17 | (*lList *pred) lambda *filt2 define 18 | 19 | ; qsort: use the first element of the list as the pivot 20 | ; filter the list and qsort the resulting lists 21 | ( (*lList) ; if it's 0 or 1 elm long, just return it 22 | (*lList uncons dup 3 unroll ; otherwise, get the next pivot, save off the pivot 23 | (***n <) cons (***n) lambda filt2 ; filter the list into greater and lesser lists 24 | *qsort swap ; sort the first part 25 | *qsort 3 roll :cons ; sort the second part, then replace the pivot 26 | append ; append them, and we're sorted 27 | ) 28 | (#t) (*lList cdr null?) *lList null? if if ) 29 | (*lList) lambda *qsort define 30 | 31 | ; some digits of pi grouped into twos for testing the sorting 32 | ;( 31 37 83 87 52 88 65 87 53 32 08 38 14 20 61 71 77 66 91 47 30 35 98 25 34 33 | ; 90 42 87 55 46 87 31 15 95 62 86 38 82 35 37 87 59 37 51 95 77 81 85 77 80 34 | ; 53 21 71 22 68 06 61 30 01 92 78 76 61 11 95 90 92 16 42 01 98 93 80 95 25 35 | ; 72 01 31 37 83 87 52 88 65 87 53 32 08 38 14 20 61 71 77 66 91 47 30 35 98 36 | ; 25 34 90 42 87 55 46 87 31 15 95 62 86 38 82 35 37 87 59 37 51 95 77 81 85 37 | ; 77 80 53 21 71 22 68 06 61 30 01 92 78 76 61 11 95 90 92 16 42 01 98 93 80 38 | ; 95 25 72 01 14 15 92 65 35 89 79 32 38 46 26 43 38 32 79 50 28 84 19 71 69 39 | ; 39 93 75 10 58 20 97 49 44 59 23 07 81 64 06 28 62 08 99 86 28 03 48 25 34 40 | ; 21 17 06 79 82 14 80 86 51 32 82 30 66 47 09 38 44 60 95 50 58 22 31 72 53 41 | ; 59 40 81 28 48 1 ) *testList define 42 | 43 | ( 141 592 653 589 793 238 462 643 383 279 502 884 197 169 399 375 105 44 | 820 974 944 592 307 816 406 286 208 998 628 034 825 342 117 067 982 148 45 | 086 513 282 306 647 093 844 609 550 582 231 725 359 408 128 481 117 450 46 | 284 102 701 938 521 105 559 644 622 948 954 930 381 964 428 810 975 665 47 | 933 446 128 475 648 233 786 783 165 271 201 909 145 648 566 923 460 348 48 | 610 454 326 648 213 393 607 260 249 141 273 724 587 006 606 315 588 174 49 | 881 520 920 962 829 254 091 715 364 367 892 590 360 011 330 530 548 820 50 | 466 521 384 146 951 941 511 609 433 057 270 365 759 591 953 092 186 117 51 | 381 932 611 793 105 118 548 074 462 379 962 749 567 351 885 752 724 891 52 | 227 938 183 011 949 129 833 673 362 440 656 643 086 021 394 946 395 224 53 | 737 190 702 179 860 943 702 770 539 217 176 293 176 752 384 674 818 467 54 | 669 405 132 000 568 127 145 263 560 827 785 771 342 757 789 609 173 637 55 | 178 721 468 440 901 224 953 430 146 549 585 371 050 792 279 689 258 923 56 | 542 019 956 112 129 021 960 864 034 418 159 813 629 774 771 309 960 518 57 | 707 211 349 999 998 372 978 049 951 059 731 732 816 096 318 595 024 459 58 | 455 346 908 302 642 522 308 253 344 685 035 261 931 188 171 010 003 137 59 | 838 752 886 587 533 208 381 420 617 177 669 147 303 598 253 490 428 755 60 | 468 731 159 562 863 882 353 787 593 751 957 781 857 780 532 171 226 806 61 | 613 001 927 876 611 195 909 216 420 198 938 095 257 201 065 485 863 278 62 | 865 936 153 381 827 968 230 301 952 035 301 852 968 995 773 622 599 413 63 | 891 249 721 775 283 479 131 515 574 857 242 454 150 695 950 829 533 116 64 | 861 727 855 889 075 098 381 754 637 464 939 319 255 060 400 927 701 671 65 | 139 009 848 824 012 858 361 603 563 707 660 104 710 181 942 955 596 198 66 | 946 767 837 449 448 255 379 774 726 847 104 047 534 646 208 046 684 259 67 | 069 491 293 313 677 028 989 152 104 752 162 056 966 024 058 038 150 193 68 | 511 253 382 430 035 587 640 247 496 473 263 914 199 272 604 269 922 796 69 | 782 354 781 636 009 341 721 641 219 924 586 315 030 286 182 974 555 706 70 | 749 838 505 494 588 586 926 995 690 927 210 797 509 302 955 321 165 344 71 | 987 202 755 960 236 480 665 499 119 881 834 797 753 566 369 807 426 542 72 | 527 862 551 818 417 574 672 890 977 772 793 800 081 647 060 016 145 249 73 | 192 173 217 214 772 350 141 441 973 568 548 161 361 157 352 552 133 475 74 | 741 849 468 438 523 323 907 394 143 334 547 762 416 862 518 983 569 485 75 | 562 099 219 222 184 272 550 254 256 887 671 790 494 601 653 466 804 988 76 | 627 232 791 786 085 784 383 827 967 976 681 454 100 953 883 786 360 950 77 | 680 064 225 125 205 117 392 984 896 084 128 488 626 945 604 241 965 285 78 | 022 210 661 186 306 744 278 622 039 194 945 047 123 713 786 960 956 364 79 | 371 917 287 467 764 657 573 962 413 890 865 832 645 995 813 390 478 027 80 | 590 099 465 764 078 951 269 468 398 352 595 709 825 822 620 522 489 407 81 | 726 719 478 268 482 601 476 990 902 640 136 394 437 455 305 068 203 496 82 | 252 451 749 399 651 431 429 809 190 659 250 937 221 696 461 515 709 858 83 | 387 410 597 885 959 772 975 498 930 161 753 928 468 138 268 683 868 942 84 | 774 155 991 855 925 245 953 959 431 049 972 524 680 845 987 273 644 695 85 | 848 653 836 736 222 626 099 124 608 051 243 884 390 451 244 136 549 762 86 | 780 797 715 691 435 997 700 129 616 089 441 694 868 555 848 406 353 422 87 | 072 225 828 488 648 158 456 028 506 016 842 739 452 267 467 678 895 252 88 | 138 522 549 954 666 727 823 986 456 596 116 354 886 230 577 456 498 035 89 | 593 634 568 174 324 112 515 076 069 479 451 096 596 094 025 228 879 710 90 | 893 145 669 136 867 228 748 940 560 101 503 308 617 928 680 920 874 760 91 | 917 824 938 589 009 714 909 675 985 261 365 549 781 893 129 784 821 682 92 | 998 948 722 658 804 857 564 014 270 477 555 132 379 641 451 523 746 234 93 | 364 542 858 444 795 265 867 821 051 141 354 735 739 523 113 427 166 102 94 | 135 969 536 231 442 952 484 937 187 110 145 765 403 590 279 934 403 742 95 | 007 310 578 539 062 198 387 447 808 478 489 683 321 445 713 868 751 943 96 | 506 430 218 453 191 048 481 005 370 614 680 674 919 278 191 197 939 952 97 | 061 419 663 428 754 440 643 745 123 718 192 179 998 391 015 919 561 814 98 | 675 142 691 239 748 940 907 186 494 231 961 567 945 208 095 146 550 225 99 | 231 603 881 930 142 093 762 137 855 956 638 937 787 083 039 069 792 077 100 | 346 722 182 562 599 661 501 421 503 068 038 447 734 549 202 605 414 665 101 | 925 201 497 442 850 732 518 666 002 132 434 088 190 710 486 331 734 649 102 | 651 453 905 796 268 561 005 508 106 658 796 998 163 574 736 384 052 571 103 | 459 102 897 064 140 110 971 206 280 439 039 759 515 677 157 700 420 337 104 | 869 936 007 230 558 763 176 359 421 873 125 147 120 532 928 191 826 186 105 | 125 867 321 579 198 414 848 829 164 470 609 575 270 695 722 091 756 711 106 | 672 291 098 169 091 528 017 350 671 274 858 322 287 183 520 935 396 572 107 | 512 108 357 915 136 988 209 144 421 006 751 033 467 110 314 126 711 136 108 | 990 865 851 639 831 501 970 165 151 168 517 143 765 761 835 155 650 884 109 | 909 989 859 982 387 345 528 331 635 507 647 918 535 893 226 185 489 632 110 | 132 933 089 857 064 204 675 259 070 915 481 416 549 859 461 637 180 270 111 | 981 994 309 924 488 957 571 282 890 592 323 326 097 299 712 084 433 573 112 | 265 489 382 391 193 259 746 366 730 583 604 142 813 883 032 038 249 037 113 | 589 852 437 441 702 913 276 561 809 377 344 403 070 746 921 120 191 302 114 | 033 038 019 762 110 110 044 929 321 516 084 244 485 963 766 983 895 228 115 | 684 783 123 552 658 213 144 957 685 726 243 344 189 303 968 642 624 341 116 | 077 322 697 802 807 318 915 441 101 044 682 325 271 620 105 265 227 211 117 | 166 039 666 557 309 254 711 055 785 376 346 682 065 310 989 652 691 862 118 | 056 476 931 257 058 635 662 018 558 100 729 360 659 876 486 117 910 453 119 | 348 850 346 113 657 686 753 249 441 668 039 626 579 787 718 556 084 552 120 | 965 412 665 408 530 614 344 431 858 676 975 145 661 406 800 700 237 877 121 | 659 134 401 712 749 470 420 562 230 538 994 561 314 071 127 000 407 854 122 | 733 269 939 081 454 664 645 880 797 270 826 683 063 432 858 785 698 305 123 | 235 808 933 065 757 406 795 457 163 775 254 202 114 955 761 581 400 250 124 | 126 228 594 130 216 471 550 979 259 230 990 796 547 376 125 517 656 751 125 | 357 517 829 666 454 779 174 501 129 961 489 030 463 994 713 296 210 734 126 | 043 751 895 735 961 458 901 938 971 311 179 042 978 285 647 503 203 198 127 | 691 514 028 708 085 990 480 109 412 147 221 317 947 647 772 622 414 254 128 | 854 540 332 157 185 306 142 288 137 585 043 063 321 751 829 798 662 237 129 | 172 159 160 771 669 254 748 738 986 654 949 450 114 654 062 843 366 393 130 | 790 039 769 265 672 146 385 306 736 096 571 209 180 763 832 716 641 627 131 | 488 880 078 692 560 290 228 472 104 031 721 186 082 041 900 042 296 617 132 | 119 637 792 133 757 511 495 950 156 604 963 186 294 726 547 364 252 308 133 | 177 036 751 590 673 502 350 728 354 056 704 038 674 351 362 222 477 158 134 | 915 049 530 984 448 933 309 634 087 807 693 259 939 780 541 934 144 737 135 | 744 184 263 129 860 809 988 868 741 326 047 215 695 162 396 586 457 302 136 | 163 159 819 319 516 735 381 297 416 772 947 867 242 292 465 436 680 098 137 | 067 692 823 828 068 996 400 482 435 403 701 416 314 965 897 940 924 323 138 | 789 690 706 977 942 236 250 822 168 895 738 379 862 300 159 377 647 165 139 | 122 893 578 601 588 161 755 782 973 523 344 604 281 512 627 203 734 314 140 | 653 197 777 416 031 990 665 541 876 397 929 334 419 521 541 341 899 485 141 | 444 734 567 383 162 499 341 913 181 480 927 777 103 863 877 343 177 207 142 | 545 654 532 207 770 921 201 905 166 096 280 490 926 360 197 598 828 161 143 | 332 316 663 652 861 932 668 633 606 273 567 630 354 477 628 035 045 077 144 | 723 554 710 585 954 870 279 081 435 624 014 517 180 624 643 626 794 561 145 | 275 318 134 078 330 336 254 232 783 944 975 382 437 205 835 311 477 119 146 | 926 063 813 346 776 879 695 970 309 833 913 077 109 870 408 591 337 464 147 | 144 282 277 263 465 947 047 458 784 778 720 192 771 528 073 176 790 770 148 | 715 721 344 473 060 570 073 349 243 693 113 835 049 316 312 840 425 121 149 | 925 651 798 069 411 352 801 314 701 304 781 643 788 518 529 092 854 520 150 | 116 583 934 196 562 134 914 341 595 625 865 865 570 552 690 496 520 985 151 | 803 385 072 242 648 293 972 858 478 316 305 777 756 068 887 644 624 824 152 | 685 792 603 953 527 734 803 048 029 005 876 075 825 104 747 091 643 961 153 | 362 676 044 925 627 420 420 832 085 661 190 625 454 337 213 153 595 845 154 | 068 772 460 290 161 876 679 524 061 634 252 257 719 542 916 299 193 064 155 | 553 779 914 037 340 432 875 262 888 963 995 879 ) dup *testList define 156 | 157 | qsort ; run quicksort on the list 158 | 159 | -------------------------------------------------------------------------------- /examples/quine.lviv: -------------------------------------------------------------------------------- 1 | 2 | ; we can use unlambda to do a weird kind of quine 3 | ( lambda unlambda swap dup 3 unroll reverse unlstk 100 *_stack_display_depth define #t *_stack_display_pretty define ) () 4 | lambda unlambda swap dup 3 unroll reverse unlstk 100 *_stack_display_depth define #t *_stack_display_pretty define 5 | 6 | -------------------------------------------------------------------------------- /examples/test.lviv: -------------------------------------------------------------------------------- 1 | ; first, let's define some testing primitives 2 | (*x) 1 *display primitive (drop) cons append 3 | 0 *newline primitive (drop) cons append 4 | (*x) lambda *displayLn define 5 | ; defines a lambda, displayLn, that displays the 1st argument and outputs newline 6 | 7 | 1 *raise primitive *raise define 8 | ; raise an error 9 | 10 | ( (clear "success") 11 | (*errMsg displayLn "assert error" raise) 12 | *target *value equal? if ) 13 | (*value *target *errMsg) lambda *assert define 14 | ; assert that the 0th entry on the stack ought to be some particular value 15 | 16 | ; square 17 | (*x dup *) (*x) lambda *square define 18 | 5 square 19 | 25 "expected 25 in 5 square" assert 20 | stk clear 21 | 22 | ; factorial 23 | ((1) (*x dup 1 - *fact *) *x 0 eq? if) (*x) lambda *fact define 24 | 5 fact 25 | 120 "expected 120 in 5 fact" assert 26 | stk clear 27 | 28 | ; fibonacci 29 | ((swap drop) (dup 3 roll + *x 1 - *fibHlp) *x 0 eq? if) (*x) lambda *fibHlp define 30 | ((0) (0 1 *x 1 - *fibHlp) *x 1 < if) (*x) lambda *fib define 31 | 5 fib 32 | 5 "expected 5 in 5 fib" assert 33 | stk clear 34 | 35 | 15 fib 36 | 610 "expected 610 in 15 fib" assert 37 | stk clear 38 | 39 | 25 fib 40 | 75025 "expected 75025 in 25 fib" assert 41 | stk clear 42 | 43 | ; another fibonacci 44 | ( ((swap drop) (dup 3 roll + **x 1 - **fibHlp) **x 0 eq? if) (**x) lambda 45 | **fibHlp define (0) (0 1 *x 1 - **fibHlp) *x 1 < if ) (*x) lambda 46 | *fib2 define 47 | 35 fib2 48 | 9227465 "expected 9227465 in 35 fib2" assert 49 | stk clear 50 | 51 | ; accumulator 52 | ( (**n) () lambda (1 **n + **nref define) () lambda 53 | *&n **nref define 1 **n define ) () lambda apply 54 | *incA define *readA define 55 | readA 56 | 1 "expected 1 in first readA" assert 57 | stk clear 58 | 59 | incA incA incA readA 60 | 4 "expected 4 in second readA" assert 61 | stk clear 62 | 63 | incA incA incA readA 64 | 7 "expected 7 in third readA" assert 65 | stk clear 66 | 67 | ; basic arithmetic 68 | 1 2 + 2 * 6 * sqrt 69 | 6 "expected 6 in sqrt" assert 70 | stk clear 71 | 72 | ; stack operations 73 | 1 3 2 2 74 | dropN 75 | 1 "expected 1 after dropN" assert 76 | stk clear 77 | 78 | ; more stack operations 79 | 1 2 3 4 5 6 80 | 3 roll 81 | unroll 82 | 5 "expected 5 after roll-unroll" assert 83 | stk clear 84 | 85 | ; list operations 86 | nil 87 | 1 :cons 88 | 2 :cons 89 | (3 4) append 90 | (2 1 3 4) "expected (2 1 3 4) after list ops" assert 91 | stk clear 92 | 93 | ; more list operations 94 | (2 1 3 4) 95 | uncons 96 | :cons 97 | cdr 98 | car 99 | 1 "expected 1 after uncons cons cdr car" assert 100 | stk clear 101 | 102 | ; define, thunk 103 | 1 *z define 104 | 2 z 105 | - 106 | (&z +) cons thunk 107 | 2 *z define 108 | apply 109 | (*z &z +) (*z) lambda apply 110 | 5 "expected 5 after define-thunk" assert 111 | stk clear 112 | 113 | ; eval stuff 114 | 1 eval 115 | *a define 116 | *a 117 | eval 118 | (*a 2) cons 119 | 4 *a define 120 | eval 121 | (1 4 2) "expected (1 4 2) after define-eval" assert 122 | stk clear 123 | 124 | ; eval and apply 125 | (1 4 2) 126 | 1 apply 127 | *:cons 128 | apply 129 | eval 130 | apply 131 | (1 1 4 2) "expected (1 1 4 2) after eval-apply" assert 132 | stk clear 133 | 134 | ; thunks 135 | (1 *z +) thunk 136 | eval 137 | dup 2 *z define apply 138 | 15 + *z define apply 139 | 19 "expected 19 after thunking around" assert 140 | stk clear 141 | 142 | ; thunks and unthunks 143 | (1 2 +) thunk 144 | dup apply 145 | swap unthunk (3 *) append thunk 146 | apply * 147 | 27 "expected 27 after thunk-unthunk" assert 148 | stk clear 149 | 150 | ; primitives 151 | 2 *expt primitive 152 | 2 3 3 roll 153 | apply 154 | 2 *expt primitive *expt define 2 expt 155 | 64 "expected 64 after expt" assert 156 | stk clear 157 | 158 | ; simple lambdas 159 | *x 160 | (1 +) cons 161 | (*y *) append 162 | (*x *y) lambda *xyfunc define 163 | 2 1 164 | xyfunc 165 | 2 *xyfunc eval 166 | apply 167 | 8 "expected 8 after simple lambda stuff" assert 168 | stk clear 169 | 170 | ; another thunk 171 | (swap 1 + swap *) thunk 172 | 2 1 3 roll 173 | apply 174 | 3 "expected 3 after lambda-equiv thunk" assert 175 | stk clear 176 | 177 | ; lambda-unlambda manipulations 178 | (1 *a +) (*a) lambda dup 179 | 3 swap apply 180 | swap unlambda 181 | (*b) append swap 182 | (*b *) append swap lambda 183 | 5 swap apply 184 | 25 "expected 25 after lambda-unlambda" assert 185 | stk clear 186 | 187 | ; let 188 | 2 *a define 189 | (&a *a *b + *) ( (*a . 1) (*b . (*a &a +)) ) let 190 | 6 *z define 191 | (*z +) cons 192 | (*a *) append ( (*a . 1) ) let 193 | 14 "expected 14 after some let tricks" assert 194 | stk clear 195 | 196 | ; conditionals 197 | 1 (nop) (0 /) #t if 198 | (3 -) (3 +) #f if 199 | (3 -) (3 +) #t swapUnless drop thunk apply 200 | ((2) (1) #t if) (0) #t if + 201 | 3 "expected 3 after if examples" assert 202 | stk clear 203 | 204 | ; tstk, untstk, rtstk 205 | 1 2 3 4 5 tstk depth 206 | 0 "expected 0 depth after tstk" assert 207 | untstk depth 5 "expected 5 depth after untstk" assert 208 | tstk 6 rtstk 6 "expected 6 after rtstk" assert 209 | stk clear 210 | 211 | ; all done 212 | "if you made it this far, all tests completed successfully" displayLn 213 | -------------------------------------------------------------------------------- /src/lviv-env.scm: -------------------------------------------------------------------------------- 1 | ;mb 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; ############# 25 | ; #### ENV #### 26 | ; ############# 27 | ; environment updates, et cetera 28 | 29 | ; env bindings 30 | (define envBindings car) 31 | (define envFirstBinding caar) 32 | (define envRemBindings cdar) 33 | (define envSetBindings set-car!) 34 | (define firstBinding car) 35 | (define restBindings cdr) 36 | (define rRestBindings cddr) 37 | (define setRestBindings set-cdr!) 38 | ; get env parent 39 | (define envParent cdr) 40 | ; no updateParent necessary, we never rebase an env 41 | 42 | ; is this the global env? 43 | (define (stGlobalEnv? state) (null? (envParent (stGetEnv state)))) 44 | 45 | ; make a new child env from the parent 46 | (define (envNewChild env) (cons '() env)) 47 | (define (stEnvNewChild state) (stUpdateEnv state (envNewChild (stGetEnv state)))) 48 | 49 | (define (stEnvParent state) 50 | (if (not (stGlobalEnv? state)) 51 | (stUpdateEnv state (envParent (stGetEnv state))))) 52 | 53 | ; convert an envBinding operation to a stEnvBinding operation 54 | (define (stEnvBindOp f) 55 | (lambda (state item) (f (stGetEnv state) item))) 56 | 57 | ; delete binding from env 58 | (define (envDelBinding local?) 59 | (lambda (env name) 60 | (letrec ((delHlp 61 | (lambda (bindings) 62 | (cond ((null? (restBindings bindings)) (eLeft "not found")) 63 | ((eq? name (car (firstBinding (restBindings bindings)))) 64 | (begin 65 | (setRestBindings bindings (rRestBindings bindings)) 66 | (eRight '()))) 67 | (else (delHlp (restBindings bindings)))))) 68 | (delRes (delay (delHlp (envBindings env)))) 69 | (nextEnv (lambda () (if local? 70 | (eLeft "not found") 71 | ((envDelBinding #f) (envParent env) name))))) 72 | ; this is weird 73 | ; to make sure that the env is bound correctly, we have to 74 | ; check the "next" one in the queue and re-link to the present spot 75 | ; this means we have to do an initial lookahead 76 | (cond ((null? env) (eLeft "not found")) 77 | ((null? (envBindings env)) (nextEnv)) 78 | ((eq? name (car (firstBinding (envBindings env)))) 79 | (envSetBindings env (restBindings (envBindings env)))) 80 | ((eRight? (force delRes)) (force delRes)) 81 | (else (nextEnv)))))) 82 | (define (stEnvDelBinding local?) (stEnvBindOp (envDelBinding local?))) 83 | 84 | ; insert an item into the environment 85 | ; does not check whether item is already there 86 | (define (envAddBinding env item) 87 | (envSetBindings env (cons item (envBindings env)))) 88 | (define stEnvAddBinding (stEnvBindOp envAddBinding)) 89 | 90 | (define (envAddMany env items) 91 | (foldl envAddBinding env items)) 92 | 93 | ; update or insert binding into env 94 | (define (envUpdateBinding env item) 95 | (letrec ((updateHlp 96 | (lambda (bindings) 97 | (cond ((null? bindings) (envAddBinding env item)) 98 | ((eq? (car item) (car (firstBinding bindings))) 99 | (set-cdr! (firstBinding bindings) (cdr item))) 100 | (else (updateHlp (restBindings bindings))))))) 101 | (updateHlp (envBindings env)))) 102 | (define stEnvUpdateBinding (stEnvBindOp envUpdateBinding)) 103 | 104 | ; lookup a binding, ascending the environment tree 105 | (define (envLookupBinding env name) 106 | (if (null? env) 107 | (eLeft "not found") ; hit the top of the environment stack 108 | (letrec ((lookupHlp 109 | (lambda (bindings) 110 | (cond ((null? bindings) (envLookupBinding (envParent env) name)) 111 | ((eq? name (car (firstBinding bindings))) 112 | (eRight (cdr (firstBinding bindings)))) 113 | (else (lookupHlp (restBindings bindings))))))) 114 | (lookupHlp (envBindings env))))) 115 | (define stEnvLookupBinding (stEnvBindOp envLookupBinding)) 116 | 117 | ; the "define" stackop 118 | ; pops a name and value off the stack. 119 | ; If the name is a static symbol, it 120 | ; updates the attached environment. Otherwise, 121 | ; it updates the current environment. 122 | (define (stDefine state) 123 | (let* ((fnIdE (stStackPop state)) 124 | (fnId (fromLeftRight fnIdE)) 125 | (fnVal (delay (stStackPop state))) 126 | (stEnvItem 127 | (delay (cons (static-symbol-sym fnId) 128 | (fromLeftRight (force fnVal))))) 129 | (envItem 130 | (delay (cons fnId 131 | (fromLeftRight (force fnVal)))))) 132 | (cond ((eLeft? fnIdE) fnIdE) 133 | ((not (symbol-elm? fnId)) 134 | (rewind state (list fnId) "invalid identifier")) 135 | ((eLeft? (force fnVal)) 136 | (rewind state (list fnId) (fromLeftRight (force fnVal)))) 137 | ((static-symbol-elm? fnId) 138 | (eRight 139 | (envUpdateBinding (static-symbol-env fnId) 140 | (force stEnvItem)))) 141 | (else 142 | (eRight (stEnvUpdateBinding state (force envItem))))))) 143 | 144 | ; undefine a variable 145 | ; if it's a static symbol, undef it in its environment 146 | ; otherwise, start from the present environment level 147 | ; and search downwards 148 | (define (stUndef local?) 149 | (lambda (state) 150 | (let* ((fnIdE (stStackPop state)) 151 | (fnId (fromLeftRight fnIdE))) 152 | (cond ((eLeft? fnIdE) fnIdE) 153 | ((not (symbol-elm? fnId)) 154 | (rewind state (list fnId) "invalid identifier")) 155 | ((static-symbol-elm? fnId) 156 | (let ((res (envDelBinding (static-symbol-env fnId) 157 | (static-symbol-sym fnId)))) 158 | (if (eLeft? res) 159 | (rewind state (list fnId) (fromLeftRight res)) 160 | res))) 161 | (else 162 | (let ((res ((stEnvDelBinding local?) state fnId))) 163 | (if (eLeft? res) 164 | (rewind state (list fnId) (fromLeftRight res)) 165 | res))))))) 166 | 167 | ; env prints out the environment 168 | (define (stEnv state) 169 | (begin (lviv-ppenv (stGetEnv state) 170 | (stEnvLookupBinding 171 | state 172 | '_stack_display_pretty)) 173 | (eRight '()))) 174 | 175 | -------------------------------------------------------------------------------- /src/lviv-exceptions.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; ############################ 25 | ; #### EXCEPTION HANDLING #### 26 | ; ############################ 27 | 28 | ; rewind is an exception object that we raise 29 | ; when we want to undo some effect on the stack 30 | (define (rewind state stackArgs msg) 31 | (raise (list 'rewind state stackArgs msg))) 32 | 33 | (define (rewind? exc) 34 | (and (list? exc) (eq? (car exc) 'rewind) (= (length exc) 4))) 35 | 36 | (define (stackError result) 37 | (raise (list 'stackError (fromLeftRight result)))) 38 | 39 | (define (stackError? exc) 40 | (and (list? exc) 41 | (= (length exc) 2) 42 | (eq? (car exc) 'stackError) 43 | (string? (cadr exc)))) 44 | 45 | (define (symbErr symb err) 46 | (raise (string-append (symbol->string symb) 47 | ": " 48 | err))) 49 | 50 | (define (dispErr_ msg) 51 | (let ((errMsg (string-append "--> error: " msg "\n"))) 52 | (display errMsg) 53 | (eLeft msg))) 54 | 55 | ; we want to provide reasonable exceptions to the user, so we do our best 56 | ; to catch what's coming from the interpreter and turn it into something 57 | ; intelligible 58 | (define (exceptionHandler display?) 59 | (lambda (exc) 60 | (let ((dispErr (if display? dispErr_ eLeft))) 61 | (cond ((rewind? exc) 62 | (let ((state (cadr exc)) 63 | (stackArgs (caddr exc)) 64 | (msg (cadddr exc))) 65 | (stStackNPush state stackArgs) 66 | (dispErr msg))) 67 | ((stackError? exc) 68 | (dispErr (cadr exc))) 69 | ((noncontinuable-exception? exc) 70 | (dispErr (noncontinuable-exception-reason exc))) 71 | ((heap-overflow-exception? exc) 72 | (dispErr "heap overflow")) 73 | ((stack-overflow-exception? exc) 74 | (dispErr "call stack overflow")) 75 | ((os-exception? exc) 76 | (dispErr (os-exception-message exc))) 77 | ((no-such-file-or-directory-exception? exc) 78 | (dispErr "no such file or directory")) 79 | ((unbound-os-environment-variable-exception? exc) 80 | (dispErr "unbound env variable")) 81 | ((scheduler-exception? exc) 82 | (dispErr "scheduler exception")) 83 | ((deadlock-exception? exc) 84 | (dispErr "deadlock exception")) 85 | ((abandoned-mutex-exception? exc) 86 | (dispErr "abandoned mutex")) 87 | ((join-timeout-exception? exc) 88 | (dispErr "join timeout")) 89 | ((started-thread-exception? exc) 90 | (dispErr "thread started")) 91 | ((terminated-thread-exception? exc) 92 | (dispErr "thread terminated")) 93 | ((uncaught-exception? exc) 94 | (dispErr "uncaught exception")) 95 | ((cfun-conversion-exception? exc) 96 | (dispErr "C function exception")) 97 | ((sfun-conversion-exception? exc) 98 | (dispErr "Sfun exception")) 99 | ((multiple-c-return-exception? exc) 100 | (dispErr "multiple C return")) 101 | ((datum-parsing-exception? exc) 102 | (dispErr "bad read")) 103 | ((expression-parsing-exception? exc) 104 | (dispErr "bad parse")) 105 | ((unbound-global-exception? exc) 106 | (dispErr (string-append 107 | "unbound global exception: " 108 | (symbol->string 109 | (unbound-global-exception-variable exc))))) 110 | ((type-exception? exc) 111 | (dispErr "type exception")) 112 | ((range-exception? exc) 113 | (dispErr "range exception")) 114 | ((improper-length-list-exception? exc) 115 | (dispErr "improper length list")) 116 | ((wrong-number-of-arguments-exception? exc) 117 | (dispErr "wrong number of arguments")) 118 | ((number-of-arguments-limit-exception? exc) 119 | (dispErr "number of arguments limit")) 120 | ((nonprocedure-operator-exception? exc) 121 | (dispErr "nonprocedure operator")) 122 | ((unknown-keyword-argument-exception? exc) 123 | (dispErr "unknown keyword argument")) 124 | ((keyword-expected-exception? exc) 125 | (dispErr "keyword expected")) 126 | ((error-exception? exc) 127 | (dispErr (string-append "error: " 128 | (if (string? (error-exception-message exc)) 129 | (error-exception-message exc) 130 | "error exception raised")))) 131 | ((divide-by-zero-exception? exc) 132 | (dispErr "divide by zero")) 133 | ((string? exc) 134 | (dispErr exc)) 135 | (else 136 | (dispErr "unknown exception")))))) 137 | 138 | (define exceptionHandlerPrint (exceptionHandler #t)) 139 | (define exceptionHandlerQuiet (exceptionHandler #f)) 140 | 141 | -------------------------------------------------------------------------------- /src/lviv-funcalls.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; ######################## 25 | ; #### FUNCTION CALLS #### 26 | ; ######################## 27 | ; all the function calling machinery 28 | ; some of the symbol defs in here should 29 | ; probably move to lviv-symbols.scm 30 | 31 | (define (stLambdaCall state binding) 32 | (if (null? (lambda-code binding)) (eRight '()) 33 | (let* ((rfunc (if (lambda-reverse? binding) reverse values)) 34 | (fnArgNames (lambda-args binding)) 35 | (fnNArgs (length fnArgNames)) 36 | (fnArgs (delay (stStackNPop state fnNArgs))) 37 | (lambdaCodeParts ; tail call optimization 38 | (splitAt (- (length (lambda-code binding)) 1) ; take the last call in the lambda 39 | (lambda-code binding))) ; apply it in tail position 40 | (lambdaState ; state during the lambda 41 | (delay 42 | (cons (stGetStackBox state) 43 | (cons (zip fnArgNames (rfunc (fromLeftRight (force fnArgs)))) 44 | (lambda-env binding))))) 45 | (fnCompResult ; apply all but last piece of code 46 | (lambda () 47 | (eRight (applyMap (force lambdaState) 48 | (car lambdaCodeParts))))) 49 | (fnResult (delay (with-exception-catcher ; catch errors in above 50 | exceptionHandlerQuiet 51 | fnCompResult))) 52 | (fnFinalEval ; eval last piece in lambda env 53 | (delay (lviv-eval (force lambdaState) (cadr lambdaCodeParts))))) 54 | (cond ((eLeft? (force fnArgs)) (force fnArgs)) 55 | ((eLeft? (force fnResult)) 56 | (rewind state 57 | (reverse (fromLeftRight (force fnArgs))) 58 | (fromLeftRight (force fnResult)))) 59 | ((eLeft? (force fnFinalEval)) ; make sure final eval works 60 | (rewind state ; otherwise rewind and throw err 61 | (reverse (fromLeftRight (force fnArgs))) 62 | (fromLeftRight (force fnFinalEval)))) 63 | ; this is like an "else", since stUpdateStack always returns a true value 64 | ; so we first update the stack, then we call the already evaluated call 65 | ; from the lambda in the original state, which gets the last call into 66 | ; tail position 67 | (else 68 | (lviv-apply (force lambdaState) (force fnFinalEval))))))) ; tail call 69 | 70 | ; primitive call 71 | ; no tail call optimization necessary here; Scheme will do it 72 | ; for calls that require it, and to us it's just one monolithic 73 | ; call 74 | (define (stPrimCall state binding) 75 | (let* ((rfunc (if (primitive-reverse? binding) reverse values)) 76 | (fnNArgs (delay (primitive-arity binding))) 77 | (fnArgs (delay (stStackNPop state (force fnNArgs)))) 78 | (fnCompResult 79 | (lambda () 80 | (eRight (apply (eval (primitive-id binding)) 81 | (rfunc (fromLeftRight (force fnArgs))))))) 82 | (fnResult (delay (with-exception-catcher 83 | exceptionHandlerQuiet 84 | fnCompResult)))) 85 | (cond ((eLeft? (force fnArgs)) (force fnArgs)) 86 | ; if there aren't enough args, the procedure fails 87 | ; and the stack doesn't get rewound any further 88 | ; note that if stStackNPop fails, it will rewind what 89 | ; it did 90 | ((eLeft? (force fnResult)) 91 | (rewind state 92 | (reverse (fromLeftRight (force fnArgs))) 93 | (fromLeftRight (force fnResult)))) 94 | ; if the primitive application fails, put the args 95 | ; back on the stack 96 | (else (stStackPush state (fromLeftRight (force fnResult))))))) 97 | ; else push the new value onto the stack 98 | 99 | -------------------------------------------------------------------------------- /src/lviv-misc.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | ; ************** 24 | ; **** MISC **** 25 | ; ************** 26 | ; miscellaneous functions 27 | 28 | ; fromTo 29 | ; make a list from x to y 30 | (define (fromTo x y) 31 | (if (>= x y) '() (cons x (fromTo (+ x 1) y)))) 32 | 33 | ; foldl 34 | ; like the Haskell function 35 | ; foldl :: (a->b->a) -> a -> [b] -> a 36 | (define (foldl f init ls) 37 | (if (null? ls) 38 | init 39 | (foldl f (f init (car ls)) (cdr ls)))) 40 | 41 | ; scanl 42 | ; like the Haskell function 43 | ; scanl :: (a->b->a) -> a -> [b] -> a 44 | (define (scanl f init ls) 45 | (if (null? ls) 46 | '() 47 | (let ((ninit (f init (car ls)))) 48 | (cons ninit (scanl f ninit (cdr ls)))))) 49 | 50 | ; list-copy 51 | (define (list-copy ls) 52 | (if (null? ls) 53 | '() 54 | (cons (car ls) (list-copy (cdr ls))))) 55 | 56 | ; zipWith 57 | ; like the Haskell function 58 | ; zipWith func l1 l2 59 | (define (zipWith f l1 l2) 60 | (cond ((null? l1) '()) 61 | ((null? l2) '()) 62 | (else (cons (f (car l1) (car l2)) 63 | (zipWith f (cdr l1) (cdr l2)))))) 64 | ; zip = zipWith cons 65 | (define (zip l1 l2) (zipWith cons l1 l2)) 66 | 67 | ; anyWith 68 | ; if the supplied test is true for any member 69 | ; of the list return #t, else return #f 70 | (define (anyWith tst lst) 71 | (foldl (lambda (x y) (or x (tst y))) #f lst)) 72 | 73 | ; allWith 74 | ; if the supplied test is false for any member 75 | ; of the list return #f, else return #t 76 | (define (allWith tst lst) 77 | (foldl (lambda (x y) (and x (tst y))) #t lst)) 78 | 79 | ; string-contains s1 s2 [start1 end1 start2 end2] -> integer or false 80 | ; string-contains-ci s1 s2 [start1 end1 start2 end2] -> integer or false 81 | ; Does string s1 contain string s2? 82 | ; Return the index in s1 where s2 occurs as a substring, or false. The 83 | ; optional start/end indices restrict the operation to the indicated 84 | ; substrings. 85 | ; We do not support the optional arguments 86 | ; this function is from http://okmij.org/ftp/Scheme/lib/srfi-13-local.scm 87 | ; as noted on http://okmij.org/ftp/, this code is in the public domain 88 | (define (string-contains str pattern) 89 | (let* ((pat-len (string-length pattern)) 90 | (search-span (- (string-length str) pat-len)) 91 | (c1 (if (zero? pat-len) #f (string-ref pattern 0))) 92 | (c2 (if (<= pat-len 1) #f (string-ref pattern 1)))) 93 | (cond 94 | ((not c1) 0) ; empty pattern, matches upfront 95 | ((not c2) (string-index str c1)) ; one-char pattern 96 | (else ; matching a pattern of at least two chars 97 | (let outer ((pos 0)) 98 | (cond 99 | ((> pos search-span) #f) ; nothing was found thru the whole str 100 | ((not (char=? c1 (string-ref str pos))) 101 | (outer (+ 1 pos))) ; keep looking for the right beginning 102 | ((not (char=? c2 (string-ref str (+ 1 pos)))) 103 | (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2.... 104 | (else ; two char matched: high probability 105 | ; the rest will match too 106 | (let inner ((i-pat 2) (i-str (+ 2 pos))) 107 | (if (>= i-pat pat-len) pos ; whole pattern matched 108 | (if (char=? (string-ref pattern i-pat) 109 | (string-ref str i-str)) 110 | (inner (+ 1 i-pat) (+ 1 i-str)) 111 | (outer (+ 1 pos)))))))))))) ; mismatch after partial match 112 | 113 | ; Return the index of the first occurence of a-char in str, or #f 114 | ; This is a subset of the corresponding SRFI-13 function. 115 | ; The latter is more generic. 116 | ; this function is from http://okmij.org/ftp/Scheme/lib/srfi-13-local.scm 117 | ; as noted on http://okmij.org/ftp/, this code is in the public domain 118 | (define (string-index str a-char) 119 | (let loop ((pos 0)) 120 | (cond 121 | ((>= pos (string-length str)) #f) ; whole string has been searched, in vain 122 | ((char=? a-char (string-ref str pos)) pos) 123 | (else (loop (+ 1 pos)))))) 124 | 125 | 126 | ; same, but for a symbol via conversion to string 127 | (define (symbol-contains k pstring) 128 | (string-contains (symbol->string k) pstring)) 129 | 130 | ; take, like the Haskell function 131 | ; take :: Int -> [a] -> [a] 132 | (define (take n lst) 133 | (cond ((= n 0) '()) 134 | ((null? lst) '()) 135 | (else (cons (car lst) (take (- n 1) (cdr lst)))))) 136 | 137 | ; splitAt, like the Haskell function 138 | ; splitAt :: Int -> [a] -> ([a],[a]) 139 | (define (splitAt n lst) 140 | (letrec 141 | ((splitAtHlp (lambda (lst n hd) 142 | (cond ((null? lst) (cons (reverse hd) '())) ; no more list to split 143 | ((<= n 0) (cons (reverse hd) lst)) 144 | (else 145 | (splitAtHlp (cdr lst) (- n 1) (cons (car lst) hd))))))) 146 | (splitAtHlp lst n '()))) 147 | 148 | ; like iterate f lst !! x 149 | (define (iterateN f n lst) 150 | (if (= n 0) lst (iterateN f (- n 1) (f lst)))) 151 | 152 | ; iterate, but quit on empty list 153 | (define (iterateNOrNull f n lst) 154 | (if (or (= n 0) (null? lst)) lst (iterateNOrNull f (- n 1) (f lst)))) 155 | 156 | ; general number to integer 157 | (define (number->int num) (inexact->exact (truncate num))) 158 | 159 | ; rollN circular shifts the first few elements of a stack 160 | ; first element becomes second, et cetera 161 | (define (rollN n lst) 162 | (let ((splitLst (splitAt (- (min n (length lst)) 1) lst))) 163 | (cons (cadr splitLst) (append (car splitLst) (cddr splitLst))))) 164 | 165 | ; unrollN circular shifts like rollN, but the other direction 166 | (define (unrollN n lst) 167 | (let ((splitLst (splitAt (min n (length lst)) lst))) 168 | (append (cdar splitLst) (cons (caar splitLst) (cdr splitLst))))) 169 | 170 | ; dupN duplicates the first n elements of a list 171 | (define (dupN n lst) 172 | (let ((splitLst (splitAt (min n (length lst)) lst))) 173 | (append (car splitLst) (append (car splitLst) (cdr splitLst))))) 174 | 175 | ; flip function of two variables 176 | (define (flip f) (lambda (x y) (f y x))) 177 | 178 | ; pickN - like a consing list-ref but uses 1-based indexing 179 | ; attempts to never produce an error 180 | (define (pickN n lst) 181 | (cond ((< n 1) lst) 182 | ((> n (length lst)) lst) 183 | (else (cons (list-ref lst (- n 1)) lst)))) 184 | 185 | ; eLeft and eRight are like the Either monad 186 | ; eRight signals success, eLeft signals failure 187 | (define (eLeft msg) (cons '(either #f) msg)) 188 | (define (eRight msg) (cons '(either #t) msg)) 189 | (define (eRight? either) (and (pair? either) (equal? '(either #t) (car either)))) 190 | (define (eLeft? either) (and (pair? either) (equal? '(either #f) (car either)))) 191 | (define fromLeftRight cdr) 192 | 193 | ; strict truth and falsity tests 194 | (define (=bool? b) 195 | (lambda (x) 196 | (if (not (boolean? x)) 197 | (raise "type error") 198 | (eq? b x)))) 199 | (define =true? (=bool? #t)) 200 | (define =false? (=bool? #f)) 201 | 202 | 203 | -------------------------------------------------------------------------------- /src/lviv-prelude.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | 23 | ; ################# 24 | ; #### PRELUDE #### 25 | ; ################# 26 | ; eventually, most of this will be defined in lviv directly 27 | ; rather than via lviv wrapped in scheme calls (but of course 28 | ; file reading will have to be implemented first!) 29 | 30 | (define lvivState (mkEmptyState)) 31 | 32 | (define (symbol->quote-symbol symb) 33 | (string->symbol (string-append "*" (symbol->string symb)))) 34 | 35 | (define (lviv-define-prim symb arity . name) 36 | (let ((qsymb (symbol->quote-symbol symb))) 37 | (if (null? name) 38 | (applyMap lvivState (quasiquote (,arity ,qsymb primitive ,qsymb define))) 39 | (let ((cName (symbol->quote-symbol (car name)))) 40 | (applyMap lvivState (quasiquote (,arity ,qsymb primitive ,cName define))))))) 41 | 42 | (define (lviv-define-val symb val) 43 | (applyMap lvivState (quasiquote (,val ,(symbol->quote-symbol symb) define)))) 44 | 45 | ; constants 46 | (define pi 3.141592653589793238462643) ; more than we can actually represent 47 | (define pi/2 (/ pi 2)) 48 | (lviv-define-val 'pi pi) 49 | (lviv-define-val 'pi/2 pi/2) 50 | (lviv-define-val 'nil '()) 51 | 52 | ; arithmetic 53 | (lviv-define-prim '+ 2) 54 | (lviv-define-prim '- 2) 55 | (lviv-define-prim '/ 2) 56 | (lviv-define-prim '* 2) 57 | 58 | (define (inv x) (/ 1 x)) (lviv-define-prim 'inv 1) 59 | (lviv-define-prim 'modulo 2 'mod) 60 | 61 | (define (chs x) (* -1 x)) 62 | (lviv-define-prim 'chs 1 'neg) 63 | (lviv-define-prim 'chs 1) 64 | (lviv-define-prim 'abs 1) 65 | 66 | (lviv-define-prim 'ceiling 1 'ceil) 67 | (lviv-define-prim 'floor 1) 68 | (lviv-define-prim 'number->int 1 'int) 69 | 70 | (define (frac x) (- x (number->int x))) 71 | (lviv-define-prim 'frac 1) 72 | 73 | (define (pct y x) (* (/ y 100) x)) 74 | (lviv-define-prim 'pct 2 '%) 75 | 76 | (define (pctOf y x) (* 100 (/ x y))) 77 | (lviv-define-prim 'pctOf 2 '%t) 78 | 79 | (define (pctCh y x) (* 100 (/ (- x y) y))) 80 | (lviv-define-prim 'pctCh 2 '%ch) 81 | 82 | ; exponential and logarithmic 83 | (lviv-define-prim 'expt 2 '^) 84 | (define (xroot y x) (expt y (/ 1 x))) (lviv-define-prim 'xroot 2) 85 | (define (cis x) (exp (* +i x))) (lviv-define-prim 'cis 1) 86 | (define (sq x) (* x x)) (lviv-define-prim 'sq 1) 87 | (lviv-define-prim 'sqrt 1) 88 | (lviv-define-prim 'exp 1) 89 | (lviv-define-prim 'log 1 'ln) 90 | 91 | (define n1toN (fromTo 1 100)) ; waaaaaaaaaay overkill 92 | (define invFacts (scanl (lambda (y x) (/ y x)) 1 n1toN)) 93 | (define invEONeg (map (lambda (x) (/ (if (even? x) -1 1) x)) n1toN)) 94 | (define m1^k (map (lambda (x) (if (even? x) 1 -1)) n1toN)) 95 | 96 | (define (expm1 x) ; use taylor expansion of e^x near 0 to reduce numerical error 97 | (if (< (magnitude x) 0.19) 98 | (letrec ((expm1Hlp 99 | (lambda (expts iFacts) 100 | (if (null? expts) 0 101 | (+ (* (expt x (car expts)) (car iFacts)) 102 | (expm1Hlp (cdr expts) (cdr iFacts))))))) 103 | (+ x (expm1Hlp (cdr n1toN) (cdr invFacts)))) 104 | (- (exp x) 1))) 105 | (lviv-define-prim 'expm1 1) 106 | 107 | (define (lnp1 x) ; use taylor expansion of ln(1+x) near 0 to reduce numerical error 108 | (if (< (magnitude x) 0.19) 109 | (letrec ((lnp1Hlp 110 | (lambda (expts quots) 111 | (if (null? expts) 0 112 | (+ (* (expt x (car expts)) (car quots)) 113 | (lnp1Hlp (cdr expts) (cdr quots))))))) 114 | (+ x (lnp1Hlp (cdr n1toN) (cdr invEONeg)))) 115 | (log (+ x 1)))) 116 | (lviv-define-prim 'lnp1 1) 117 | 118 | (define ln10 (log 10)) (define (log10 x) (/ (log x) ln10)) (lviv-define-prim 'log10 1 'log) 119 | (define (alog x) (expt 10 x)) (lviv-define-prim 'alog 1) 120 | (lviv-define-prim 'sin 1) 121 | (lviv-define-prim 'cos 1) 122 | (lviv-define-prim 'tan 1) 123 | (define (sec x) (/ 1 (cos x))) (lviv-define-prim 'sec 1) 124 | (define (csc x) 125 | (if (= x 0) +inf.0 (/ 1 (sin x)))) (lviv-define-prim 'csc 1) 126 | (define (cot x) 127 | (if (= x 0) +inf.0 (/ 1 (tan x)))) (lviv-define-prim 'cot 1) 128 | (lviv-define-prim 'asin 1) 129 | (lviv-define-prim 'acos 1) 130 | (lviv-define-prim 'atan 1) 131 | (define (asec x) 132 | (if (= 0 x) +inf.0i (acos (/ 1 x)))) (lviv-define-prim 'asec 1) 133 | (define (acsc x) 134 | (if (= 0 x) (- pi/2 +inf.0i) (asin (/ 1 x)))) (lviv-define-prim 'acsc 1) 135 | (define (acot x) 136 | (if (= 0 x) pi/2 (atan (/ 1 x)))) (lviv-define-prim 'acot 1) 137 | (define (d>r x) (* pi (/ x 180))) (lviv-define-prim 'd>r 1) 138 | (define (r>d x) (* 180 (/ x pi))) (lviv-define-prim 'r>d 1) 139 | (lviv-define-prim 'atan 2 'atan2) 140 | (define (vers x) (- 1 (cos x))) (lviv-define-prim 'vers 1) 141 | (define (hav x) (/ (vers x) 2)) (lviv-define-prim 'hav 1) 142 | 143 | ; bernouilli numbers for estimating tanh 144 | ; ** sinh(x)/cosh(x) is sufficiently accurate 145 | ; ** so we'll just do that instead 146 | ; ** note: the following algorithm is basically a direct 147 | ; implementation of the Akiyama-Tanigawa triangle from 148 | ; http://www.cs.uwaterloo.ca/journals/JIS/VOL3/KANEKO/AT-kaneko.pdf 149 | ;(define maxBN 101) 150 | ;(define n1toNBN (fromTo 1 maxBN)) 151 | ;(define bnL (list (map (lambda (x) (/ 1 x)) n1toNBN))) 152 | ;(set-cdr! bnL (cons (cdar bnL) '())) 153 | ;(define (updateNthBN n bn) 154 | ; (if (< (length bn) n) (raise "need predecessor") 155 | ; (let ((bncdr (iterateN cdr (- n 1) bn))) 156 | ; (set-cdr! bncdr 157 | ; (cons (zipWith * n1toNBN 158 | ; (zipWith - (car bncdr) (cdar bncdr))) 159 | ; '()))))) 160 | ;(map (lambda (x) (updateNthBN x bnL)) (cdr n1toNBN)) 161 | ;(define bNums (reverse (map car (cdr (reverse bnL))))) 162 | (define (everyOther ls) 163 | (if (or (null? ls) (null? (cdr ls))) 164 | '() 165 | (cons (car ls) (everyOther (cddr ls))))) 166 | ;(define tanhFacts 167 | ; (zipWith 168 | ; * (everyOther (cddr bNums)) 169 | ; (zipWith (lambda (x y) (* (- (expt 4 x) (expt 2 x)) 170 | ; y)) 171 | ; (everyOther (cdr n1toNBN)) 172 | ; (everyOther (cdr invFacts))))) 173 | 174 | ; hyperbolic functions 175 | (define (sinh x) 176 | (if (< (magnitude x) 0.19) 177 | (letrec ((sinhHlp 178 | (lambda (expts iFacts) 179 | (if (or (null? expts) (null? (cdr expts))) 0 180 | (+ (* (expt x (car expts)) (car iFacts)) 181 | (sinhHlp (cddr expts) (cddr iFacts))))))) 182 | (+ x (sinhHlp (cddr n1toN) (cddr invFacts)))) 183 | (let ((expx (exp x))) (/ (- expx (inv expx)) 2)))) 184 | (lviv-define-prim 'sinh 1) 185 | (define (cosh x) 186 | (if (< (magnitude x) 0.19) 187 | (letrec ((coshHlp 188 | (lambda (expts iFacts) 189 | (if (or (null? expts) (null? (cdr expts))) 0 190 | (+ (* (expt x (car expts)) (car iFacts)) 191 | (coshHlp (cddr expts) (cddr iFacts))))))) 192 | (+ 1 (coshHlp (cdr n1toN) (cdr invFacts)))) 193 | (let ((expx (exp x))) (/ (+ expx (inv expx)) 2)))) 194 | (lviv-define-prim 'cosh 1) 195 | 196 | ;(define (tanh x) 197 | ; (if (< (magnitude x) 0.19) 198 | ; (letrec ((tanhHlp 199 | ; (lambda (ks xps) 200 | ; (if (null? ks) 0 201 | ; (+ (* (car ks) (expt x (car xps))) 202 | ; (tanhHlp (cdr ks) (cddr xps))))))) 203 | ; (+ x (tanhHlp (cdr tanhFacts) (cddr n1toN)))) 204 | ; (let ((exp2x (exp (* 2 x)))) (/ (- exp2x 1) (+ exp2x 1))))) 205 | 206 | ; this is for the case where sinh(x) and cosh(x) blow up to +inf.0 207 | ; we know that in this case they blow up in such a way that the 208 | ; correct answer is just 1 209 | ; this seems kludgy but is reasonably accurate and faster than 210 | ; the Taylor expansion 211 | (define (tanh x) 212 | (let ((sinhx (sinh x)) 213 | (coshx (cosh x))) 214 | (cond ((= sinhx coshx) 1) ; the divide operator doesn't work with inf 215 | ((= sinhx (* -1 coshx)) -1) ; so we have to kludge a little bit 216 | (else (/ sinhx coshx))))) 217 | (lviv-define-prim 'tanh 1) 218 | 219 | (define acoshTArgs 220 | (zipWith * (everyOther (cddr invFacts)) 221 | (map sq (scanl * 1 (everyOther n1toN))))) 222 | (define asinhTArgs 223 | (zipWith * acoshTArgs m1^k)) 224 | (define (asinh x) 225 | (if (< (magnitude x) 0.35) 226 | (letrec ((asinhHlp 227 | (lambda (xp ta) 228 | (if (null? ta) 0 229 | (+ (* (expt x (car xp)) (car ta)) 230 | (asinhHlp (cddr xp) (cdr ta))))))) 231 | (+ x (asinhHlp (cddr n1toN) asinhTArgs))) 232 | (log (+ x (sqrt (+ (sq x) 1)))))) 233 | (lviv-define-prim 'asinh 1) 234 | 235 | (define (acosh x) 236 | (if (< (magnitude x) 0.75) 237 | (letrec ((acoshHlp 238 | (lambda (xp ta) 239 | (if (null? ta) 0 240 | (+ (* (expt x (car xp)) (car ta)) 241 | (acoshHlp (cddr xp) (cdr ta))))))) 242 | (+ (log -i) 243 | (* +i (+ x (acoshHlp (cddr n1toN) acoshTArgs))))) 244 | (log (+ x (sqrt (- (sq x) 1)))))) 245 | (lviv-define-prim 'acosh 1) 246 | 247 | (define (atanh x) (/ (- (lnp1 x) (lnp1 (chs x))) 2)) 248 | (lviv-define-prim 'atanh 1) 249 | 250 | (define (sech x) (inv (cosh x))) 251 | (lviv-define-prim 'sech 1) 252 | (define (csch x) (inv (sinh x))) 253 | (lviv-define-prim 'csch 1) 254 | (define (coth x) (inv (tanh x))) 255 | (lviv-define-prim 'coth 1) 256 | 257 | (define (asech x) 258 | (if (= x 0) +inf.0 (log (/ (+ 1 (sqrt (- 1 (sq x)))) x)))) 259 | (lviv-define-prim 'asech 1) 260 | 261 | (define (acsch x) 262 | (if (= x 0) +inf.0 (log (+ (inv x) (/ (sqrt (+ 1 (sq x))) (magnitude x)))))) 263 | (lviv-define-prim 'acsch 1) 264 | 265 | (define mipi/2 (acosh 0)) 266 | (define (acoth x) 267 | (if (< (magnitude x) 0.19) 268 | ((if (< x 0) - +) (atanh x) mipi/2) 269 | (/ (- (lnp1 (inv x)) (lnp1 (chs (inv x)))) 2))) 270 | (lviv-define-prim 'acoth 1) 271 | 272 | ; complex number functions 273 | (lviv-define-prim 'magnitude 1 'mag) 274 | (lviv-define-prim 'angle 1 'arg) 275 | (lviv-define-prim 'imag-part 1 'im) 276 | (lviv-define-prim 'real-part 1 're) 277 | (lviv-define-prim 'make-rectangular 2 'cxrect) 278 | (lviv-define-prim 'make-polar 2 'cxpolar) 279 | 280 | ; relational 281 | (lviv-define-prim 'eq? 2) 282 | (lviv-define-prim 'equal? 2) 283 | (lviv-define-prim '= 2) 284 | (lviv-define-prim '< 2) 285 | (lviv-define-prim '> 2) 286 | (lviv-define-prim '<= 2) 287 | (lviv-define-prim '>= 2) 288 | (define (andF y x) (and y x)) (lviv-define-prim 'andF 2 'and) 289 | (define (orF y x) (or y x)) (lviv-define-prim 'orF 2 'or) 290 | (define (xor y x) (or (and y (not x)) (and x (not y)))) 291 | (lviv-define-prim 'xor 2) 292 | (lviv-define-prim 'not 1) 293 | 294 | ; misc 295 | (define (fact x) (if (< x 1) 1 (* x (fact (- x 1))))) 296 | (lviv-define-prim 'fact 1 '!) 297 | (define (rnd y x) (/ (round (* y (alog x))) (alog x))) 298 | (lviv-define-prim 'rnd 2) 299 | (lviv-define-prim 'min 2) 300 | (lviv-define-prim 'max 2) 301 | (define (sign x) (cond ((< x 0) -1) ((> x 0) 1) (else 0))) 302 | (lviv-define-prim 'sign 1) 303 | (define (psign x) (cond ((< x 0) -1) (else 1))) 304 | (lviv-define-prim 'psign 1) 305 | (define (xpon x) 306 | (cond ((zero? x) 0) 307 | ((and (real? x) (nan? x)) +nan.0) 308 | ((and (real? x) (infinite? x)) 0) 309 | ((and (complex? x) 310 | (let ((imagx (imag-part x)) 311 | (realx (real-part x))) 312 | (or (infinite? imagx) 313 | (nan? imagx) 314 | (infinite? realx) 315 | (nan? realx)))) 316 | 0) 317 | (else (inexact->exact (floor (/ (log (magnitude x)) ln10)))))) 318 | (lviv-define-prim 'xpon 1) 319 | (define (mant x) 320 | (if (zero? x) 321 | 0 (/ x (expt 10 (xpon x))))) 322 | (lviv-define-prim 'mant 1) 323 | (lviv-define-prim 'inexact->exact 1 'exact) 324 | (lviv-define-prim 'exact->inexact 1 'inexact) 325 | (lviv-define-prim 'random-integer 1 'randInt) 326 | (lviv-define-prim 'random-real 0 'rand) 327 | (define (perm y x) 328 | (cond ((> x y) 0) 329 | ((or (< x 1) (< y 1)) 0) 330 | (else 331 | (letrec 332 | ((tfact 333 | (lambda (n st) 334 | (if (= n st) 1 (* n (tfact (- n 1) st)))))) 335 | (tfact y (- y x)))))) 336 | (lviv-define-prim 'perm 2) 337 | (define (comb y x) (/ (perm y x) (fact x))) 338 | (lviv-define-prim 'comb 2) 339 | 340 | ; list manipulations 341 | (lviv-define-prim 'append 2) 342 | (lviv-define-prim 'cons 2) 343 | (lviv-define-prim 'null? 1) 344 | (lviv-define-prim 'reverse 1) 345 | 346 | (define (add-cxrs state n) 347 | (letrec ((nums (take n '(1 2 4 8 16))) 348 | (bitAD 349 | (lambda (cnt) 350 | (apply string-append 351 | (map (lambda (x) 352 | (if (= (modulo (quotient cnt x) 2) 0) "a" "d")) 353 | nums)))) 354 | (acHlp 355 | (lambda (cnt) 356 | (if (= (expt 2 n) cnt) #t 357 | (let ((nxName (string->symbol (string-append "c" (bitAD cnt) "r")))) 358 | (stEnvUpdateBinding state 359 | (cons nxName 360 | (mkPrimBinding nxName 1))) 361 | (acHlp (+ cnt 1))))))) 362 | (acHlp 0))) 363 | 364 | (add-cxrs lvivState 4) 365 | (add-cxrs lvivState 3) 366 | (add-cxrs lvivState 2) 367 | (add-cxrs lvivState 1) 368 | -------------------------------------------------------------------------------- /src/lviv-repl.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; ############### 25 | ; #### EVAL ##### 26 | ; ############### 27 | ; repl 28 | 29 | ; pop off an elm from the stack and eval it 30 | (define (stEval state) 31 | (let* ((fnEArg (stStackPop state)) 32 | (fnArg (fromLeftRight fnEArg))) 33 | (if (eLeft? fnEArg) 34 | fnEArg 35 | (stStackPush state (lviv-eval state fnArg))))) 36 | 37 | ; eval->apply on a list 38 | ; this is used to evaluate keyboard input and for thunks 39 | (define (applyMap state elm) 40 | (map (lambda (x) 41 | (lviv-apply state (lviv-eval state x))) 42 | elm)) 43 | 44 | ; since lviv-apply always works on AST, stApply and lviv-apply are 45 | ; basically identical, but we have to wrap a safe pop around the 46 | ; former to get the latter 47 | ; thunks are treated specially by stApply; it unwraps and eval->applies them 48 | (define (stApply state) ; 49 | (let* ((fnEArg (stStackPop state)) ; pop off element 50 | (fnArg (fromLeftRight fnEArg))) 51 | (cond ((eLeft? fnEArg) fnEArg) ; pop unsuccessful? 52 | ((thunkElm? fnArg) ; thunk? 53 | (if (null? (thunkElm->elm fnArg)) (eRight '()) ; do nothing with null thunk 54 | (let* ((thunkCode (thunkElm->elm fnArg)) ; else perform tail call opt 55 | (thunkCodeParts (splitAt (- (length thunkCode) 1) 56 | thunkCode))) 57 | (begin (applyMap state (car thunkCodeParts)) ; call first part of thunk 58 | (lviv-apply ; then tail call last part 59 | state 60 | (lviv-eval state 61 | (cadr thunkCodeParts))))))) 62 | (else (lviv-apply state fnArg))))) ; otherwise, just apply it like anything else 63 | 64 | ; mapping of stackop to procedure 65 | (define stackOpMapping 66 | (list `(depth . ,stStackDepth) 67 | `(swap . ,stStackSwap) 68 | `(drop . ,stStackDrop) 69 | `(clear . ,stStackClear) 70 | `(dropN . ,stStackDropN) 71 | `(roll . ,stStackRollN) 72 | `(unroll . ,stStackUnrollN) 73 | `(dup . ,stStackDup) 74 | `(dupN . ,stStackDupN) 75 | `(over . ,stStackOver) 76 | `(pick . ,stStackPickN) 77 | `(swapIf . ,stStackSwapIf) 78 | `(swapUnless . ,stStackSwapUnless) 79 | `(dropIf . ,stStackDropIf) 80 | `(dropUnless . ,stStackDropUnless) 81 | `(uncons . ,stStackUncons) 82 | `(define . ,stDefine) 83 | `(undefLocal . ,(stUndef #t)) 84 | `(undef . ,(stUndef #f)) 85 | `(eval . ,stEval) 86 | `(apply . ,stApply) 87 | `(thunk . ,stStackThunk) 88 | `(unthunk . ,stUnThunk) 89 | `(lambda . ,stLambda) 90 | `(unlambda . ,stUnLambda) 91 | `(primitive . ,stPrimitive) 92 | `(if . ,stIf) 93 | `(unless . ,stUnless) 94 | `(env . ,stEnv) 95 | `(nop . ,stNop) 96 | `(let . ,stLet) 97 | `(tstk . ,stTStk) 98 | `(dtstk . ,stDTStk) 99 | `(untstk . ,(stUnTStk #f)) 100 | `(rtstk . ,(stUnTStk #t)) 101 | `(stk . ,stPrintStack) 102 | `(lstk . ,stStackToList) 103 | `(unlstk . ,stListToStack) 104 | )) 105 | 106 | ; list of stackops; doing this now lets us not 107 | ; call car for every lookup in the list above 108 | (define stackOpListing (map car stackOpMapping)) 109 | 110 | ; lookup item in association list 111 | (define (carLookup symb lst) 112 | (if (eq? symb (caar lst)) 113 | (cdar lst) 114 | (carLookup symb (cdr lst)))) 115 | 116 | 117 | ; the main eval procedure 118 | (define (lviv-eval state item) 119 | (let ((lookupElm (lambda (env name) 120 | (let ((lkRef (envLookupBinding env name))) 121 | (if (eLeft? lkRef) 122 | (symbErr name "lookup failed") 123 | (fromLeftRight lkRef)))))) 124 | (cond ((symbol? item) 125 | (cond ((member item stackOpListing) ; stackop? 126 | (mkStackOpElm ; make stackop element 127 | (carLookup item stackOpMapping) 128 | item)) 129 | ((static-symbol-unchecked? item) ; &foo -> (& foo env) 130 | (mkStaticSymbolElm item (stGetEnv state))) 131 | ((quote-symbol-unchecked? item) ; *bar -> bar 132 | (mkQuoteSymbolElm item)) 133 | ((reverse-symbol-unchecked? item) ; :cons -> cons in reverse 134 | (let ((iBind (lookupElm (stGetEnv state) 135 | (reverse-symbol->symbol item)))) ; look it up 136 | (cond ((primitive? iBind) (prim-reverse iBind)) ; reverse if possible 137 | ((lambda? iBind) (lambda-reverse iBind)) ; " 138 | (else ; otherwise, error 139 | (symbErr (reverse-symbol->symbol item) 140 | "can only reverse lambda or primitive"))))) 141 | (else ; otherwise 142 | (lookupElm (stGetEnv state) 143 | item)))) 144 | ((static-symbol-elm? item) 145 | (lookupElm (static-symbol-env item) ; static symbol 146 | (static-symbol-sym item))) ; resolve in attached env 147 | ((lviv-tagged? item) item) ; all other lviv-tagged items are idempotent 148 | ((and (list? item) (pair? item)) ; has to be list and not nil 149 | (map (lambda (x) (lviv-eval state x)) item)) ; eval the contents 150 | ((pair? item) ; a pair gets car and cdr evaluated 151 | (cons (lviv-eval state (car item)) 152 | (lviv-eval state (cdr item)))) 153 | (else item)))) ; otherwise, I guess it's idempotent 154 | 155 | ; apply the output from eval to the stack 156 | (define (lviv-apply state item) 157 | ((lambda (result) (if (eLeft? result) (stackError result) result)) 158 | (cond ((eLeft? item) item) 159 | ((elm? item) 160 | (cond ((stackOpElm-unchecked? item) ; stackop gets executed 161 | ((stackOpElm->stackop item) state)) 162 | ((primitive-unchecked? item) ; primitive gets called 163 | (stPrimCall state item)) 164 | ((lambda-unchecked? item) ; lambda gets called 165 | (stLambdaCall state item)) 166 | (else ; other elms are idempotent 167 | (stStackPush state item)))) 168 | (else (stStackPush state item))))) ; else just push it on the stack 169 | 170 | ; slurp in input by repeatedly reading until there's no more 171 | ; to be had. We (read-all) does this for us, but we have to 172 | ; set the timeout to zero so the user doesn't have to ^D 173 | (define (read-list . port) 174 | (let* ((port (if (null? port) (current-input-port) (car port))) 175 | (toSet0 (input-port-timeout-set! port 0)) 176 | (readRes (read-all)) 177 | (toSetf (input-port-timeout-set! port #f))) 178 | readRes)) 179 | 180 | ; we use read-list rather than read so that we get all of the inputs at once, 181 | ; and don't end up printing the state of the stack between each element in 182 | ; the input as we apply them 183 | (define (lviv-repl state input) ; repl 184 | (cond ((equal? input '(#!eof)) #f) 185 | (else 186 | (let ((allInput (append input (read-list)))) 187 | (with-exception-catcher exceptionHandlerPrint 188 | (lambda () (applyMap state allInput)))) 189 | (stPrintStack state) 190 | (display "> ") 191 | (lviv-repl state (list (read)))))) 192 | 193 | ; read in a file as if entered at the repl 194 | (define (lviv-file state file) 195 | (let* ((fInput (with-exception-catcher 196 | exceptionHandlerQuiet 197 | (lambda () (open-input-file file)))) 198 | (fRead (delay (read-all fInput)))) 199 | (if (eLeft? fInput) 200 | fInput 201 | (begin (with-exception-catcher 202 | exceptionHandlerPrint 203 | (lambda () (applyMap state (force fRead)))) 204 | (stPrintStack state))))) 205 | 206 | ; default stack display depth 207 | (define _stack_display_depth 10) 208 | 209 | ; engineering notation 210 | (define (eng num) 211 | (let ((x (or (and (number? num) num) (string->number num)))) 212 | (cond 213 | ((not x) (raise "type exception")) 214 | ((and (not (real? x)) (complex? x)) 215 | (string-append 216 | (eng (real-part x)) 217 | (if (< (psign (imag-part x)) 0) "-" "+") 218 | (eng (imag-part x)) 219 | "i")) 220 | (else 221 | (let* ((xxpon (xpon x)) 222 | (x3pon (* 3 223 | (- (quotient xxpon 3) 224 | (if (and 225 | (< xxpon 0) 226 | (not (zero? (remainder xxpon 3)))) 227 | 1 0)))) 228 | (xmant (/ x (expt 10 x3pon)))) 229 | (string-append (number->string 230 | (exact->inexact (rnd xmant 12))) 231 | "e" 232 | (number->string x3pon))))))) 233 | 234 | ; prettyprint for lviv elements 235 | (define (lviv-pp newline? ugly? intEng?) 236 | (lambda (elm) 237 | (let ((newln (lambda () (if newline? (display "\n") (display " ")))) 238 | (ppLocal (lviv-pp #f ugly? intEng?))) 239 | (cond ((static-symbol-elm? elm) 240 | (begin (display "&") 241 | (display (static-symbol-sym elm)) 242 | (and ugly? (begin (display "(env#") 243 | (display (static-symbol-sn elm)) 244 | (display ")"))) 245 | (newln))) 246 | ((stackOpElm? elm) 247 | (begin (and ugly? (display "#")) 250 | (newln))) 251 | ((thunkElm? elm) 252 | (begin (and ugly? (display "#elm elm)) 254 | (and ugly? (display ")>")) 255 | (newln))) 256 | ((lambda? elm) 257 | (begin (and ugly? (display "#"))) 265 | (newln))) 266 | ((primitive? elm) 267 | (begin (and ugly? (display "#")) 271 | (newln))) 272 | ((and (list? elm) (pair? elm)) 273 | (begin (display "( ") 274 | (map ppLocal elm) 275 | (display " )") 276 | (newln))) 277 | ((pair? elm) 278 | (begin (display "( ") 279 | (ppLocal (car elm)) 280 | (display ". ") 281 | (ppLocal (cdr elm)) 282 | (display " )") 283 | (newln))) 284 | ((and (number? elm) 285 | (or (and (inexact? elm) (> (abs (xpon elm)) 3)) 286 | (and intEng? (> (abs (xpon elm)) 6)))) 287 | (begin (display (eng elm)) 288 | (newln))) 289 | ((symbol? elm) 290 | (begin (display "*") 291 | (display elm) 292 | (newln))) 293 | ((string? elm) 294 | (begin (display "\"") 295 | (display elm) 296 | (display "\"") 297 | (newln))) 298 | (else 299 | (begin (display elm) 300 | (newln))))))) 301 | 302 | ; pretty-print the stack 303 | (define (lviv-ppstack stack eDepth pretty? intEng?) 304 | (let ((depth (if (eRight? eDepth) 305 | (fromLeftRight eDepth) 306 | _stack_display_depth)) 307 | (pprint (if (eRight? pretty?) 308 | (not (fromLeftRight pretty?)) 309 | #t)) 310 | (intEng (if (eRight? intEng?) 311 | (fromLeftRight intEng?) 312 | #f))) 313 | (map (lviv-pp #t pprint intEng) 314 | (reverse (take (number->int depth) stack))))) 315 | 316 | ; pretty-print the environment, surrounding 317 | ; each level of the env with a { } 318 | (define (lviv-ppenv env pretty?) 319 | (let ((pprint (if (eRight? pretty?) 320 | (not (fromLeftRight pretty?)) 321 | #t))) 322 | (let loop ((e env)) 323 | (if (null? e) 324 | (newline) 325 | (begin (display "{\n") 326 | (map (lviv-pp #t pprint) (car e)) 327 | (display "}\n") 328 | (loop (cdr e))))))) 329 | -------------------------------------------------------------------------------- /src/lviv-specforms.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; *********************** 25 | ; **** SPECIAL FORMS **** 26 | ; *********************** 27 | ; most of these functions handle special forms 28 | ; like lambda, let, define, et cetera 29 | ; if is in here, but it's really syntactic sugar 30 | 31 | ; uncons 32 | ; if the first element of the stack is a list, replace it 33 | ; with car and cdr of list in 0th and 1st positions, respectively 34 | (define (stackUncons stack) 35 | (let* ((popVal (stackPop stack)) 36 | (popEither (car popVal)) 37 | (popRes (fromLeftRight popEither)) 38 | (popRem (cdr popVal))) 39 | (cond ((eLeft? popEither) popVal) 40 | ((not (pair? popRes)) (cons (eLeft "not a pair") stack)) 41 | (else (cons (eRight '()) 42 | (append (list (car popRes) (cdr popRes)) 43 | popRem)))))) 44 | (define (stStackUncons state) (stStackUpd2 stackUncons state)) 45 | 46 | ; a thunk is a piece of code that is idempotent through eval 47 | ; and requires an apply to get "opened up" 48 | ; applying a thunk is like evaling its contents 49 | (define (stackThunk stack) 50 | (if (> (depth stack) 0) 51 | (cons (eRight '()) (cons (mkThunkElm (car stack)) (cdr stack))) 52 | (cons (eLeft "thunk: stack empty")))) 53 | (define (stStackThunk state) (stStackUpd2 stackThunk state)) 54 | 55 | ; turn a thunk back into its code 56 | (define (stUnThunk state) 57 | (let* ((fnLArg (stStackPop state)) 58 | (fnArg (fromLeftRight fnLArg))) 59 | (cond ((eLeft? fnLArg) fnLArg) 60 | ((thunkElm? fnArg) 61 | (stStackPush state (thunkElm->elm fnArg))) 62 | (else 63 | (rewind state (list fnArg) "not a thunk"))))) 64 | 65 | ; if 66 | ; if 67 | (define (stIf state) 68 | (begin (stStackSwapUnless state) 69 | (stStackDrop state) 70 | (stStackThunk state) 71 | (stApply state))) 72 | 73 | ; unless 74 | ; if 75 | (define (stUnless state) 76 | (begin (stStackSwapIf state) 77 | (stStackDrop state) 78 | (stStackThunk state) 79 | (stApply state))) 80 | 81 | ; nop does nothing 82 | (define (stNop state) (eRight '())) 83 | 84 | ; turn some code and a binding list into a lambda 85 | ; put it on the stack 86 | (define (stLambda state) 87 | (let* ((fnLArgs (stStackNPop state 2)) 88 | (fnArgs (delay (cadr (fromLeftRight fnLArgs)))) 89 | (fnxCode (delay (car (fromLeftRight fnLArgs)))) 90 | (fnCode 91 | (delay 92 | (if (list? (force fnxCode)) 93 | (force fnxCode) 94 | (list (force fnxCode))))) 95 | (fnLambda 96 | (delay (mkLambda (force fnCode) 97 | (force fnArgs) 98 | (stGetEnv state))))) 99 | (cond ((eLeft? fnLArgs) fnLArgs) ; popN failed 100 | ((not (list? (force fnArgs))) 101 | (rewind state (reverse (fromLeftRight fnLArgs)) 102 | "invalid arglist supplied")) 103 | ((not (allWith quote-symbol-elm? (force fnArgs))) 104 | (rewind state (reverse (fromLeftRight fnLArgs)) 105 | "arglist must be quoted symbols")) 106 | (else 107 | (eRight (stStackPush state (force fnLambda))))))) 108 | 109 | ; take the code and args from a lambda 110 | ; and put them on a stack 111 | (define (stUnLambda state) 112 | (let* ((fnLArg (stStackPop state)) 113 | (fnArg (fromLeftRight fnLArg))) 114 | (cond ((eLeft? fnLArg) fnLArg) 115 | ((lambda? fnArg) 116 | (stStackPush state (lambda-code fnArg)) 117 | (stStackPush state (lambda-args fnArg))) 118 | (else 119 | (rewind state (list fnArg) "not a lambda"))))) 120 | 121 | ; create a primitive binding. 122 | (define (stPrimitive state) 123 | (let* ((fnLArgs (stStackNPop state 2)) 124 | (fnId (delay (cadr (fromLeftRight fnLArgs)))) 125 | (fnArity (delay (car (fromLeftRight fnLArgs)))) 126 | (fnBinding (delay (mkPrimBinding (force fnId) 127 | (force fnArity))))) 128 | (cond ((eLeft? fnLArgs) fnLArgs) 129 | (else (eRight (stStackPush state 130 | (force fnBinding))))))) 131 | 132 | ; `let` makes a temporary environment and executes a thunk in it 133 | ; let 134 | ; is a list of name-value pairs 135 | ; values are executed in sequence as thunks, and after 136 | ; execution the top value on the stack is popped and 137 | ; bound to the given name in the temporary environment 138 | (define (stLet state) 139 | (let* ((fnLArgs (stStackNPop state 2)) ; args for the let 140 | (fnBinds (delay (cadr (fromLeftRight fnLArgs)))) ; let-bindings 141 | (fnxCode (delay (car (fromLeftRight fnLArgs)))) ; let-code 142 | (fnCode ; make sure let-code is a list 143 | (delay 144 | (if (list? (force fnxCode)) 145 | (force fnxCode) 146 | (list (force fnxCode))))) 147 | (fnCodeParts (delay (splitAt (- (length (force fnCode)) 1) ; split code for 148 | (force fnCode)))) ; tail call optimization 149 | (fnState (delay (cons (stGetStackBox state) ; make a new state for the let 150 | (envNewChild (stGetEnv state))))) 151 | (fnCompResult ; run the first part of the code 152 | (lambda () 153 | (eRight (applyMap (force fnState) 154 | (car (force fnCodeParts)))))) 155 | (fnResult (delay (with-exception-catcher ; wrap above with exception handler 156 | exceptionHandlerQuiet 157 | fnCompResult))) 158 | (fnLastEval ; last eval happens inside let environ 159 | (delay (lviv-eval (force fnState) (cadr (force fnCodeParts)))))) 160 | (cond ((eLeft? fnLArgs) fnLArgs) ; popN failed 161 | ((not (list? (force fnBinds))) ; invalid bindings - not a list 162 | (rewind state (reverse (fromLeftRight fnLArgs)) 163 | "invalid bindings supplied")) 164 | ((not (allWith ; invalid bindings - not assoc list 165 | (lambda (x) 166 | (and (pair? x) 167 | (quote-symbol-elm? (car x)))) 168 | (force fnBinds))) 169 | (rewind state (reverse (fromLeftRight fnLArgs)) 170 | "binding list must be pairs of (sym . binding)")) 171 | ((not (allWith ; run the bindings 172 | (lambda (x) 173 | (let ((bindVal (delay (stStackPop (force fnState)))) 174 | (bindCode 175 | (allWith eRight? 176 | (applyMap (force fnState) 177 | (if (list? (cdr x)) 178 | (cdr x) 179 | (list (cdr x))))))) 180 | (and bindCode 181 | (eRight? (force bindVal)) 182 | (stEnvAddBinding 183 | (force fnState) 184 | (cons (car x) 185 | (fromLeftRight (force bindVal))))))) 186 | (force fnBinds))) 187 | (rewind state (reverse (fromLeftRight fnLArgs)) 188 | "bindings failed")) 189 | ((eLeft? (force fnResult)) ; run computation, rewind if exception 190 | (rewind state 191 | (reverse (fromLeftRight fnLArgs)) 192 | (fromLeftRight (force fnResult)))) 193 | ((eLeft? (force fnLastEval)) ; check that last eval was successful 194 | (rewind state ; otherwise rewind and throw error 195 | (reverse (fromLeftRight fnLArgs)) 196 | (fromLeftRight (force fnLastEval)))) 197 | ; this is an "else" since stUpdateStack always returns a true value 198 | ; update the stack with whatever new values from the let, then run 199 | ; the final computation 200 | (else 201 | (lviv-apply (force fnState) (force fnLastEval)))))) 202 | 203 | -------------------------------------------------------------------------------- /src/lviv-stack.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; *************** 25 | ; **** STACK **** 26 | ; *************** 27 | ; operations that work directly on the stack, generally 28 | ; constituting or used by the lviv primitive stack operations 29 | 30 | ; update stack, returning a value 31 | ; supplied function should return a value such that 32 | ; result is (car (f stack)) 33 | ; newStk is (cdr (f stack)) 34 | (define (stStackUpd2 f state) 35 | (let* ((fValue (f (stGetStack state))) 36 | (fResult (car fValue)) 37 | (fRemain (cdr fValue))) 38 | (stUpdateStack state fRemain) 39 | fResult)) 40 | 41 | ; update stack, returning new stack 42 | ; cannot return an error 43 | (define (stStackUpd f state) 44 | (let ((fValue (f (stGetStack state)))) 45 | (stUpdateStack state fValue) 46 | (eRight '()))) 47 | 48 | ; push onto stack 49 | (define (stackPush var) 50 | (lambda (stack) (cons var stack))) 51 | (define (stStackPush state var) 52 | (stStackUpd (stackPush var) state)) 53 | 54 | ; push a list of values back onto the stack 55 | (define (stackNPush var) 56 | (lambda (stack) (append var stack))) 57 | (define (stStackNPush state var) 58 | (stStackUpd (stackNPush var) state)) 59 | 60 | ; stack depth 61 | (define depth length) 62 | (define (stStackDepth state) (stStackPush state (depth (stGetStack state)))) 63 | 64 | ; pop off stack 65 | ; when popping, return (cons ) 66 | ; since we represent the stack as a list, pop is just 67 | ; the identity function 68 | (define (stackPop stack) 69 | (if (> (depth stack) 0) 70 | (cons (eRight (car stack)) (cdr stack)) 71 | (cons (eLeft "pop: stack empty") '()))) 72 | 73 | (define (stStackPop state) (stStackUpd2 stackPop state)) 74 | 75 | ; pop n items off stack 76 | ; this is used when executing functions 77 | (define (stackPopN n) 78 | (lambda (stack) 79 | (if (< (depth stack) n) 80 | (cons (eLeft "popN: not enough arguments") stack) 81 | (letrec ((sPopNHlp 82 | (lambda (stack accum n) 83 | (if (= n 0) 84 | (cons (eRight accum) stack) 85 | (sPopNHlp (cdr stack) (cons (car stack) accum) (- n 1)))))) 86 | (sPopNHlp stack '() n))))) 87 | (define (stStackNPop state n) (stStackUpd2 (stackPopN n) state)) 88 | 89 | ; swap the 0th and 1st elements of the stack 90 | (define (stackSwap stack) 91 | (if (> (depth stack) 1) 92 | (cons (eRight '()) (cons (cadr stack) (cons (car stack) (cddr stack)))) 93 | (cons (eLeft "swap: not enough elements") stack))) 94 | (define (stStackSwap state) (stStackUpd2 stackSwap state)) 95 | 96 | ; drop the 0th element 97 | (define (stackDrop stack) 98 | (if (> (depth stack) 0) 99 | (cons (eRight '()) (cdr stack)) 100 | (cons (eLeft "drop: stack empty") '()))) 101 | (define (stStackDrop state) (stStackUpd2 stackDrop state)) 102 | 103 | ; clear the stack, i.e., replace it with emptyState 104 | (define stackClear (lambda (x) (mkEmptyStack))) 105 | (define (stStackClear state) (stStackUpd stackClear state)) 106 | 107 | ; a generalized stack operation that takes the 0th elem 108 | ; off the stack, expecting an integer, and produces a 109 | ; modified stack as a result 110 | (define (stackOpN f) 111 | (lambda (stack) 112 | (let* ((popVal (stackPop stack)) 113 | (popEither (car popVal)) 114 | (popRes (fromLeftRight popEither)) 115 | (popNum (and (number? popRes) (number->int popRes))) 116 | (popRem (cdr popVal))) 117 | (cond ((eLeft? popEither) popVal) 118 | (popNum 119 | (if (<= popRes (depth popRem)) 120 | (cons (eRight '()) (f popRes popRem)) 121 | (cons (eLeft "stackOpN: not enough elements") stack))) 122 | (else (cons (eLeft "stackOpN: non-numeric argument") stack)))))) 123 | 124 | ; drop N elements after the 0th 125 | (define stackDropN 126 | (stackOpN (lambda (n st) (iterateNOrNull cdr n st)))) 127 | (define (stStackDropN state) (stStackUpd2 stackDropN state)) 128 | 129 | ; roll the top N elements after the 0th 130 | (define stackRollN (stackOpN rollN)) 131 | (define (stStackRollN state) (stStackUpd2 stackRollN state)) 132 | 133 | ; unroll the top N elements after the 0th 134 | (define stackUnrollN (stackOpN unrollN)) 135 | (define (stStackUnrollN state) (stStackUpd2 stackUnrollN state)) 136 | 137 | ; dup the top element 138 | (define (stackDup stack) 139 | (if (> (depth stack) 0) 140 | (cons (eRight '()) (cons (car stack) stack)) 141 | (cons (eLeft "dup: stack empty") '()))) 142 | (define (stStackDup state) (stStackUpd2 stackDup state)) 143 | 144 | ; dup the first N elements after the 0th 145 | (define stackDupN (stackOpN dupN)) 146 | (define (stStackDupN state) (stStackUpd2 stackDupN state)) 147 | 148 | ; duplicate the second element on the stack 149 | (define (stackOver stack) 150 | (if (> (depth stack) 1) 151 | (cons (eRight '()) (cons (cadr stack) stack)) 152 | (cons (eLeft "over: not enough elements") stack))) 153 | (define (stStackOver state) (stStackUpd2 stackOver state)) 154 | 155 | ; duplicate the nth element on the stack 156 | (define stackPickN (stackOpN pickN)) 157 | (define (stStackPickN state) (stStackUpd2 stackPickN state)) 158 | 159 | ; generalized stack operation that takes the 0th elem 160 | ; off the stack and evaluates it for truth. If true, 161 | ; a supplied stackop is executed as long as there are 162 | ; sufficient elements in the stack 163 | (define (stackOpBool bool f) 164 | (lambda (stack) 165 | (let* ((popVal (stackPop stack)) 166 | (popEither (car popVal)) 167 | (popRes (fromLeftRight popEither)) 168 | (popRem (cdr popVal))) 169 | (with-exception-catcher 170 | (lambda (x) (cons (eLeft "type error") stack)) 171 | (lambda () 172 | (cond ((eLeft? popEither) popVal) 173 | ((bool popRes) (f popRem)) 174 | (else (cons (eRight '()) popRem)))))))) 175 | 176 | ; swapIf 177 | (define stackSwapIf 178 | (stackOpBool =true? stackSwap)) 179 | (define (stStackSwapIf state) (stStackUpd2 stackSwapIf state)) 180 | 181 | ; swapUnless 182 | (define stackSwapUnless 183 | (stackOpBool =false? stackSwap)) 184 | (define (stStackSwapUnless state) (stStackUpd2 stackSwapUnless state)) 185 | 186 | ; dropIf 187 | (define stackDropIf 188 | (stackOpBool =true? stackDrop)) 189 | (define (stStackDropIf state) (stStackUpd2 stackDropIf state)) 190 | 191 | ; dropUnless 192 | (define stackDropUnless 193 | (stackOpBool =false? stackDrop)) 194 | (define (stStackDropUnless state) (stStackUpd2 stackDropUnless state)) 195 | 196 | ; temporary stack 197 | (define (stTStk state) 198 | (eRight (stUpdateStackBox state (cons '() (stGetStackBox state))))) 199 | 200 | ; make temp stack with copy of present stack's contents 201 | (define (stDTStk state) 202 | (let ((pStackBox (stGetStackBox state))) 203 | (eRight (stUpdateStackBox state 204 | (cons (list-copy (car pStackBox)) 205 | pStackBox))))) 206 | 207 | ; undo temp stack, optionally returning last value 208 | (define (stUnTStk return?) 209 | (lambda (state) 210 | (cond ((< (length (stGetStackBox state)) 2) 211 | (eLeft "already in outermost stack")) 212 | (return? 213 | (let ((toPush (stStackPop state))) 214 | (if (eLeft? toPush) 215 | toPush 216 | (begin (stUpdateStackBox 217 | state (cdr (stGetStackBox state))) 218 | (eRight (stStackPush 219 | state 220 | (fromLeftRight toPush))))))) 221 | (else 222 | (eRight 223 | (stUpdateStackBox 224 | state (cdr (stGetStackBox state)))))))) 225 | 226 | ; display the stack 227 | (define (stPrintStack state) 228 | (lviv-ppstack (stGetStack state) 229 | (stEnvLookupBinding 230 | state 231 | '_stack_display_depth) 232 | (stEnvLookupBinding 233 | state 234 | '_stack_display_pretty) 235 | (stEnvLookupBinding 236 | state 237 | '_stack_display_int_eng))) 238 | 239 | ; turn the stack into a list, which becomes 240 | ; the only element on the stack 241 | (define (stackToList stack) 242 | (list '() stack)) 243 | (define (stStackToList state) 244 | (stStackUpd2 stackToList state)) 245 | 246 | ; opposite of the above - take 0th element 247 | ; on the stack, and expand it onto the stack 248 | (define (listToStack stack) 249 | (cons '() (append (car stack) (cdr stack)))) 250 | (define (stListToStack state) 251 | (stStackUpd2 listToStack state)) 252 | 253 | -------------------------------------------------------------------------------- /src/lviv-state.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; *************** 25 | ; **** STATE **** 26 | ; *************** 27 | ; functions relating to interpreter state 28 | 29 | ; an empty stack 30 | (define mkEmptyStack (lambda () '())) 31 | (define mkEmptyStackBox (lambda () (cons (mkEmptyStack) '()))) 32 | 33 | ; an empty environment 34 | (define mkEmptyEnv (lambda () (cons '() '()))) 35 | 36 | ; an interpreter state is just (stack . env) 37 | (define mkEmptyState (lambda () (cons (mkEmptyStackBox) (mkEmptyEnv)))) 38 | 39 | ; retrieve stack from the state 40 | (define stGetStack caar) 41 | (define stGetStackBox car) 42 | 43 | ; retrieve env from the state 44 | (define stGetEnv cdr) 45 | 46 | ; update environment 47 | (define (stUpdateEnv oldState newEnv) (set-cdr! oldState newEnv)) 48 | (define (stUpdateStack oldState newStack) (set-car! (car oldState) newStack)) 49 | (define (stUpdateStackBox oldState newStackBox) (set-car! oldState newStackBox)) 50 | -------------------------------------------------------------------------------- /src/lviv-symbols.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; **************************** 25 | ; **** SYMBOL DEFINITIONS **** 26 | ; **************************** 27 | ; all the crap with the #lviv# tags and whatnot 28 | 29 | ; lviv-tag is used to tag internal objects 30 | (define lviv-tag '|(<#lviv#>)|) 31 | (define (mklvivtag x) (cons lviv-tag x)) 32 | (define (lviv-tagged? x) 33 | (and (vector? x) 34 | (pair? (vector-ref x 0)) 35 | (eq? lviv-tag (car (vector-ref x 0))))) 36 | 37 | ; illegal symbol is used to check static and quote symbols 38 | ; for legality. In particular, we care that the second character 39 | ; of the symbol isn't something illegal 40 | (define illegal-chars (list #\& #\* #\. #\+ #\-)) 41 | (define (illegal-symbol? symb) 42 | (member (string-ref (symbol->string symb) 1) illegal-chars)) 43 | (define (illegal-quote-symbol? symb) 44 | (member (string-ref (symbol->string symb) 1) (cddr illegal-chars))) 45 | 46 | (define elm? vector?) 47 | (define mkElm vector) 48 | (define (elmRef elm n) (vector-ref elm n)) 49 | (define elmLen vector-length) 50 | (define elmCopy vector-copy) 51 | (define (elmSet elm n val) (vector-set! elm n val)) 52 | 53 | ; meta-test for symbolicity 54 | ; give it the symbol sigil and it 55 | ; returns the test function 56 | (define (x-symbol? char) 57 | (lambda (symb) 58 | (and (symbol? symb) 59 | (let ((symb-str (symbol->string symb))) 60 | (and (eq? char (string-ref symb-str 0)) 61 | (> (string-length symb-str) 1)))))) 62 | 63 | ; like x-symbol?, but without 64 | ; symbolicity check for faster 65 | ; eval 66 | (define (x-symbol-unchecked? char) 67 | (lambda (symb) 68 | (let ((symb-str (symbol->string symb))) 69 | (and (eq? char (string-ref symb-str 0)) 70 | (> (string-length symb-str) 1))))) 71 | 72 | ; meta-converter 73 | ; give it the sigil and an error msg 74 | ; it returns the conversion function 75 | (define (x-symbol->symbol symb) 76 | (let ((symb-str (symbol->string symb))) 77 | (string->symbol (substring symb-str 1 (string-length symb-str))))) 78 | 79 | ; meta-test for symbol-elementicity (that is, symbol in AST) 80 | ; give it symbol and length of representation 81 | (define (x-symbol-elm? symTag len) 82 | (lambda (elm) 83 | (and (elm? elm) 84 | (equal? symTag 85 | (elmRef elm 0)) 86 | (= len (elmLen elm))))) 87 | 88 | ; like x-symbol-elm? but without 89 | ; the elm? check for faster apply 90 | (define (x-symbol-elm-unchecked? symTag len) 91 | (lambda (elm) 92 | (and (equal? symTag 93 | (elmRef elm 0)) 94 | (= len (elmLen elm))))) 95 | 96 | ; static symbol functions 97 | (define static-symbol? (x-symbol? #\&)) 98 | (define static-symbol-unchecked? (x-symbol-unchecked? #\&)) 99 | (define static-symbol->symbol x-symbol->symbol) 100 | (define staticLvivTag (mklvivtag '&)) 101 | (define (mkStaticSymbolElm symb env) 102 | (if (illegal-symbol? symb) ; make sure it's legal 103 | (eLeft "illegal symbol") ; oops 104 | (mkElm staticLvivTag (static-symbol->symbol symb) env))) 105 | (define static-symbol-elm? (x-symbol-elm? staticLvivTag 3)) 106 | (define (static-symbol-env elm) (elmRef elm 2)) 107 | (define (static-symbol-sn elm) (object->serial-number 108 | (static-symbol-env elm))) 109 | (define (static-symbol-sym elm) (elmRef elm 1)) 110 | 111 | ; quote symbol functions 112 | (define quote-symbol? (x-symbol? #\*)) 113 | (define quote-symbol-unchecked? (x-symbol-unchecked? #\*)) 114 | (define (mkQuoteSymbolElm symb) 115 | (or (and (symbol? symb) (quote-symbol->symbol symb)) ; make sure it's legal 116 | (eLeft "illegal quote symbol"))) ; otherwise error 117 | (define quote-symbol->symbol x-symbol->symbol) 118 | (define quote-symbol-elm? symbol?) 119 | 120 | ; is this symbol reversed? 121 | (define reverse-symbol? (x-symbol? #\:)) 122 | (define reverse-symbol-unchecked? (x-symbol-unchecked? #\:)) 123 | (define reverse-symbol->symbol x-symbol->symbol) 124 | 125 | ; is this an element that can be used to define an environment variable? 126 | (define (symbol-elm? item) (or (static-symbol-elm? item) 127 | (quote-symbol-elm? item))) 128 | 129 | ; stackops in AST 130 | (define stackopLvivTag (mklvivtag 'stackop)) 131 | (define (mkStackOpElm op name) (mkElm stackopLvivTag op name)) 132 | (define stackOpElm? (x-symbol-elm? stackopLvivTag 3)) 133 | (define stackOpElm-unchecked? (x-symbol-elm-unchecked? stackopLvivTag 3)) 134 | (define (stackOpElm->stackop elm) (elmRef elm 1)) 135 | (define (stackOpElm-sym elm) (elmRef elm 2)) 136 | 137 | ; thunks in AST 138 | (define thunkLvivTag (mklvivtag 'thunk)) 139 | (define (mkThunkElm op) 140 | (mkElm thunkLvivTag 141 | (if (list? op) 142 | op 143 | (list op)))) 144 | (define thunkElm? (x-symbol-elm? thunkLvivTag 2)) 145 | (define (thunkElm->elm elm) (elmRef elm 1)) 146 | 147 | ; make a lambda to stick in the env 148 | (define lambdaLvivTag (mklvivtag 'lambda)) 149 | (define (mkLambda code args env) 150 | (mkElm lambdaLvivTag args code env #f)) 151 | (define lambda? (x-symbol-elm? lambdaLvivTag 5)) 152 | (define lambda-unchecked? (x-symbol-elm-unchecked? lambdaLvivTag 5)) 153 | ; reverse order of application 154 | (define (lambda-reverse binding) 155 | (let ((newElm (elmCopy binding))) 156 | (elmSet newElm 4 (not (lambda-reverse? binding))) 157 | newElm)) 158 | (define (lambda-args elm) (elmRef elm 1)) 159 | (define (lambda-code elm) (elmRef elm 2)) 160 | (define (lambda-env elm) (elmRef elm 3)) 161 | (define (lambda-reverse? elm) (elmRef elm 4)) 162 | 163 | ; make a primitive binding to stick in the env 164 | (define primitiveLvivTag (mklvivtag 'primitive)) 165 | (define (mkPrimBinding id arity) 166 | (mkElm primitiveLvivTag arity id #f)) 167 | (define primitive? (x-symbol-elm? primitiveLvivTag 4)) 168 | (define primitive-unchecked? (x-symbol-elm-unchecked? primitiveLvivTag 4)) 169 | ; change a binding to its reverse 170 | (define (prim-reverse binding) 171 | (let ((newElm (elmCopy binding))) 172 | (elmSet newElm 3 (not (primitive-reverse? binding))) 173 | newElm)) 174 | ; primitives 175 | (define (primitive-arity elm) (elmRef elm 1)) 176 | (define (primitive-id elm) (elmRef elm 2)) 177 | (define (primitive-reverse? elm) (elmRef elm 3)) 178 | 179 | -------------------------------------------------------------------------------- /src/lviv-tests.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ;Copyright (c) 2011 Riad S. Wahby 3 | ; 4 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 5 | ;of this software and associated documentation files (the "Software"), to deal 6 | ;in the Software without restriction, including without limitation the rights 7 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | ;copies of the Software, and to permit persons to whom the Software is 9 | ;furnished to do so, subject to the following conditions: 10 | ; 11 | ;The above copyright notice and this permission notice shall be included in 12 | ;all copies or substantial portions of the Software. 13 | ; 14 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | ;THE SOFTWARE. 21 | ; 22 | ; 23 | 24 | ; ############### 25 | ; #### TESTS #### 26 | ; ############### 27 | 28 | (define (test x msg) 29 | (or x (raise msg))) 30 | 31 | (define (testLookup x val) 32 | (test (and (eRight? (stEnvLookupBinding lvivState x)) 33 | (equal? (fromLeftRight (stEnvLookupBinding lvivState x)) val)) 34 | (string-append (symbol->string x) " lookup failed"))) 35 | 36 | (define (testStack val msg) 37 | (test (equal? (stGetStack lvivState) val) msg)) 38 | 39 | (stStackPush lvivState 1) 40 | (stStackPush lvivState 2) 41 | (stStackPush lvivState 3) 42 | (stStackPush lvivState 4) 43 | (stStackPush lvivState 5) 44 | (stStackPush lvivState 2) 45 | (testStack '(2 5 4 3 2 1) "push tests failed") 46 | 47 | (stStackSwap lvivState) 48 | (testStack '(5 2 4 3 2 1) "swap test failed") 49 | 50 | (stStackDrop lvivState) 51 | (testStack '(2 4 3 2 1) "drop test failed") 52 | 53 | (stStackDropN lvivState) 54 | (testStack '(2 1) "dropN test failed") 55 | 56 | (stStackClear lvivState) 57 | (testStack '() "clear test failed") 58 | 59 | (stStackPush lvivState 1) 60 | (stStackPush lvivState 2) 61 | (stStackPush lvivState 3) 62 | (stStackPush lvivState 4) 63 | (stStackPush lvivState 5) 64 | (stStackRollN lvivState) 65 | (testStack '(5 4 3 2 1) "opN not enough args test failed") 66 | (stStackPush lvivState 3) 67 | (stStackRollN lvivState) 68 | (testStack '(3 5 4 2 1) "rollN test failed") 69 | 70 | (stStackPush lvivState 2) 71 | (stStackUnrollN lvivState) 72 | (testStack '(5 3 4 2 1) "unrollN test failed") 73 | 74 | (stStackDup lvivState) 75 | (testStack '(5 5 3 4 2 1) "dup test failed") 76 | 77 | (stStackPush lvivState 3) 78 | (stStackDupN lvivState) 79 | (testStack '(5 5 3 5 5 3 4 2 1) "dupN test failed") 80 | 81 | (stStackPush lvivState 'a) 82 | (stStackDupN lvivState) 83 | (testStack '(a 5 5 3 5 5 3 4 2 1) "opN non-numeric test failed") 84 | 85 | (stStackOver lvivState) 86 | (testStack '(5 a 5 5 3 5 5 3 4 2 1) "over test failed") 87 | 88 | (stStackPush lvivState '5) 89 | (stStackPickN lvivState) 90 | (testStack '(3 5 a 5 5 3 5 5 3 4 2 1) "pickN test failed") 91 | 92 | (stPrimCall lvivState (mkPrimBinding '+ 2)) 93 | (testStack '(8 a 5 5 3 5 5 3 4 2 1) "hidden primitive test failed") 94 | 95 | (stStackDropN lvivState) 96 | (testStack '(2 1) "dropN test failed") 97 | 98 | (stStackPush lvivState '#t) 99 | (stStackDropUnless lvivState) 100 | (testStack '(2 1) "#t dropUnless test failed") 101 | 102 | (stStackPush lvivState '#f) 103 | (stStackDropUnless lvivState) 104 | (testStack '(1) "#f dropUnless test failed") 105 | 106 | (stStackPush lvivState 5) 107 | (stStackDropUnless lvivState) 108 | (testStack '(5 1) "non-bool dropUnless test failed") 109 | 110 | (stStackPush lvivState #f) 111 | (stStackDropIf lvivState) 112 | (testStack '(5 1) "#f dropIf test failed") 113 | 114 | (stStackPush lvivState #t) 115 | (stStackDropIf lvivState) 116 | (testStack '(1) "#t dropIf test failed") 117 | 118 | (stStackDropIf lvivState) 119 | (testStack '(1) "non-bool dropIf test failed") 120 | 121 | (stStackPush lvivState 5) 122 | (stStackPush lvivState #t) 123 | (stStackSwapIf lvivState) 124 | (testStack '(1 5) "#t swapIf test failed") 125 | 126 | (stStackPush lvivState 5) 127 | (stStackPush lvivState #f) 128 | (stStackSwapIf lvivState) 129 | (testStack '(5 1 5) "#f swapIf test failed") 130 | 131 | (stStackSwapIf lvivState) 132 | (testStack '(5 1 5) "non-bool swapIf test failed") 133 | 134 | (stStackPush lvivState #f) 135 | (stStackPush lvivState #t) 136 | (stStackSwapUnless lvivState) 137 | (testStack '(#f 5 1 5) "#t swapUnless test failed") 138 | 139 | (stStackSwapUnless lvivState) 140 | (testStack '(1 5 5) "#f swapUnless test failed") 141 | 142 | (stStackSwapUnless lvivState) 143 | (testStack '(1 5 5) "non-bool swapUnless test failed") 144 | 145 | (stEnvUpdateBinding lvivState (cons 'a 1)) 146 | (stEnvUpdateBinding lvivState (cons 'b 2)) 147 | (stEnvUpdateBinding lvivState (cons 'c 3)) 148 | (stEnvUpdateBinding lvivState (cons 'd 4)) 149 | (stEnvUpdateBinding lvivState (cons 'e 5)) 150 | (stEnvUpdateBinding lvivState (cons 'a 6)) 151 | ((stEnvDelBinding #f) lvivState 'd) 152 | 153 | (test (eLeft? (stEnvLookupBinding lvivState 'd)) "d still bound!?") 154 | (testLookup 'e 5) 155 | 156 | (stEnvNewChild lvivState) 157 | (stEnvUpdateBinding lvivState '(f 100)) 158 | (stEnvUpdateBinding lvivState '(b 200)) 159 | 160 | (testLookup 'e 5) 161 | (testLookup 'f '(100)) 162 | (testLookup 'b '(200)) 163 | 164 | (test (eLeft? (stEnvLookupBinding lvivState 'd)) "d still bound!? (2)") 165 | 166 | (stEnvParent lvivState) 167 | (stEnvParent lvivState) 168 | (stEnvParent lvivState) 169 | (stEnvParent lvivState) 170 | 171 | (test (stGlobalEnv? lvivState) "should be global env here") 172 | 173 | (stEnvNewChild lvivState) 174 | (stEnvUpdateBinding lvivState '(f 100)) 175 | (stEnvUpdateBinding lvivState '(b 200)) 176 | 177 | (test (not (stGlobalEnv? lvivState)) "should not be global env here") 178 | 179 | (stEnvParent lvivState) 180 | (stEnvParent lvivState) 181 | (test (stGlobalEnv? lvivState) "should be global env here") 182 | 183 | (lviv-apply lvivState (lviv-eval lvivState '+)) 184 | 185 | (testStack '(6 5) "state of stack is wrong after +") 186 | 187 | (lviv-apply lvivState (lviv-eval lvivState '*b)) 188 | (lviv-apply lvivState (lviv-eval lvivState '*a)) 189 | 190 | (test (eLeft? 191 | (with-exception-catcher exceptionHandlerQuiet 192 | (lambda () (stPrimCall lvivState (lviv-eval lvivState '+))))) 193 | "call to + failed to fail") 194 | 195 | (testStack '(a b 6 5) "stack is in wrong state after type failure") 196 | 197 | (testLookup 'cdr (mkPrimBinding 'cdr 1)) 198 | 199 | (applyMap lvivState '(() cons cons (-) append (*a *b) lambda apply)) 200 | (testStack '(1) "stack is in wrong state after lambda") 201 | 202 | (applyMap lvivState '((&a +) cons thunk apply)) 203 | (testStack '(7) "stack is in wrong state after thunk") 204 | 205 | (applyMap lvivState '(*a undef)) 206 | (test (eLeft? (stEnvLookupBinding lvivState 'a)) "a still bound after undef?") 207 | 208 | (applyMap lvivState '(*a define)) 209 | (applyMap lvivState '((&b &a *a * +) ((*a . (&a 2 +))) let)) 210 | (testStack '(65) "stack is in wrong state after let") 211 | 212 | (applyMap lvivState '(drop)) 213 | 214 | (applyMap lvivState '(*a *b *c *e undef undef undef undef)) 215 | -------------------------------------------------------------------------------- /src/lviv.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env gsi-script 2 | ; 3 | ;Copyright (c) 2011 Riad S. Wahby 4 | ; 5 | ;Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;of this software and associated documentation files (the "Software"), to deal 7 | ;in the Software without restriction, including without limitation the rights 8 | ;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;copies of the Software, and to permit persons to whom the Software is 10 | ;furnished to do so, subject to the following conditions: 11 | ; 12 | ;The above copyright notice and this permission notice shall be included in 13 | ;all copies or substantial portions of the Software. 14 | ; 15 | ;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | ;THE SOFTWARE. 22 | ; 23 | ; 24 | 25 | (include "lviv-misc.scm") 26 | (include "lviv-state.scm") 27 | (include "lviv-stack.scm") 28 | (include "lviv-env.scm") 29 | (include "lviv-specforms.scm") 30 | (include "lviv-exceptions.scm") 31 | (include "lviv-symbols.scm") 32 | (include "lviv-funcalls.scm") 33 | (include "lviv-repl.scm") 34 | (include "lviv-prelude.scm") 35 | (include "lviv-tests.scm") 36 | 37 | ; go through each arg in the arglist 38 | ; - means run a repl 39 | ; 40 | (define (lviv-process-args arglist) 41 | (cond ((null? arglist) #f) 42 | ((equal? "-" (car arglist)) 43 | (lviv-repl lvivState '()) 44 | (lviv-process-args (cdr arglist))) 45 | (else 46 | (lviv-file lvivState (car arglist)) 47 | (lviv-process-args (cdr arglist))))) 48 | 49 | ; decide how to proceed based on commandline 50 | ; if a -- is supplied, ignore all args before it 51 | ; otherwise, attempt to open and eval all args 52 | ; other than the 0th 53 | ; this mimics the difference between script mode 54 | ; and batch mode in gsi 55 | (let ((c--line (member "--" (command-line))) 56 | (c1line (cdr (command-line)))) 57 | (cond ((null? c1line) ; no arguments at all 58 | (display "welcome to lviv\n\n") 59 | (lviv-repl lvivState '())) 60 | ((not c--line) ; didn't find -- delimiter 61 | (lviv-process-args c1line)) 62 | ((null? (cdr c--line)) ; found --, if it's last arg just do repl 63 | (display "welcome to lviv\n\n") 64 | (lviv-repl lvivState '())) 65 | ; otherwise process args after -- 66 | (else 67 | (lviv-process-args (cdr c--line))))) 68 | 69 | ; print the stack before we exit 70 | (define (main . _) #f) 71 | --------------------------------------------------------------------------------