├── .bugs ├── bugs └── details │ ├── 499afb16915b64d56aff710d292b46ddaa060869.txt │ ├── 4d4e76343fe09f0ec72a3e5eb0077bd16e12f9d5.txt │ ├── 6749f3abcb9455eac9271efd8265797bce114239.txt │ ├── 7a57614fa920b2ddad002d044b144d0bb7c34f84.txt │ ├── 8cf6202873d4454f57813dd17cf60432059f7c62.txt │ ├── 91bcbbe2453226a053e02b84601cc22f43087b29.txt │ ├── ce28d6c0d1f9894c9b946e56b17934473800edfe.txt │ ├── d6de2074a5017f1f29f34d142ce797981ed270a0.txt │ ├── d9147504868960e5fbc2648474d48ce5c9bd1a02.txt │ ├── e445b9ed2403cd366e556f384129c08970f0b77a.txt │ └── e445b9ed2403cd366e556f384129c08970f0b77a.txt.orig ├── .hgsigs ├── .hgtags ├── AUTHORS.in ├── COPYING ├── Makefile.am ├── NEWS ├── README ├── README.md ├── bootstrap-reader.sh ├── bootstrap.sh ├── configure.ac ├── docs ├── _minted-fosdem2019 │ └── default.pygstyle ├── fosdem2016.org ├── fosdem2019.org ├── handwritten-code.jpg ├── interactive-run.txt ├── srfi-119 │ ├── README │ ├── bootstrap.sh │ ├── srfi-testsuite.html │ ├── wisp-bootstrap.py │ ├── wisp-guile.scm │ ├── wisp-guile.w │ ├── wisp-scheme.scm │ └── wisp-scheme.w ├── srfi-from-template.html ├── srfi-testsuite.html ├── srfi.html ├── srfi.org ├── tutorial.org ├── ui │ ├── default │ │ ├── blank.gif │ │ ├── bodybg.gif │ │ ├── framing.css │ │ ├── iepngfix.htc │ │ ├── opera.css │ │ ├── outline.css │ │ ├── pretty.css │ │ ├── print.css │ │ ├── s5-core.css │ │ ├── slides.css │ │ └── slides.js │ ├── i18n │ │ ├── 00_head.txt │ │ ├── bg-shade.png │ │ ├── bg-slide.jpg │ │ ├── framing.css │ │ ├── pretty.css │ │ ├── s5-core.css │ │ └── slides.css │ ├── jquery.js │ └── org-slides.js ├── uniinput.sty └── why-wisp.org ├── examples ├── Makefile ├── advent-2016-day-7.scm ├── advent-2016-day-7.w ├── argparse.scm ├── argparse.w ├── benchmark.scm ├── benchmark.w ├── bits-as-numberstring.w ├── cartesian-sets.scm ├── cartesian-sets.w ├── cholesky.scm ├── cholesky.w ├── cli.scm ├── cli.w ├── closure.scm ├── closure.w ├── coffee.scm ├── coffee.w ├── commandline-handling.scm ├── commandline-handling.w ├── comment-server.scm ├── comment-server.w ├── d20world.scm ├── d20world.w ├── d6.scm ├── d6.w ├── doctests-test.scm ├── doctests-test.w ├── doctests-testone.scm ├── doctests.scm ├── doctests.w ├── doctestss-testone.scm ├── downloadmesh.scm ├── downloadmesh.w ├── duel.scm ├── duel.w ├── ensemble-estimation.scm ├── ensemble-estimation.w ├── enter-three-witches.scm ├── enter-three-witches.w ├── evaluate-r7rs-benchmark.gnuplot ├── evaluate-r7rs-benchmark.png ├── evaluate-r7rs-benchmark.scm ├── evaluate-r7rs-benchmark.w ├── evolve.scm ├── evolve.w ├── factorial.scm ├── factorial.w ├── fib.scm ├── fib.w ├── files │ └── test ├── fizzbuzz.scm ├── fizzbuzz.w ├── gnuplot.w ├── graph-algorithms.w ├── guile-ecraven-benchmarks-result-2017-08-13.csv ├── guile-gi.w ├── hamming-file.w ├── hamming.w ├── heapsort.w ├── hello-world-server.scm ├── hello-world-server.w ├── hoist-in-loop.scm ├── hoist-in-loop.w ├── ild.scm ├── ild.w ├── kit-encode.scm ├── kit-encode.w ├── lisp2wisp.w ├── macros.scm ├── macros.w ├── map-product-sums.scm ├── map-product-sums.w ├── mercurial.scm ├── mercurial.w ├── multithreaded-magic.scm ├── multithreaded-magic.w ├── network.w ├── newbase60.scm ├── newbase60.w ├── pipe.scm ├── pipe.w ├── power-iteration.scm ├── power-iteration.w ├── property.scm ├── property.w ├── ptifrrabirrf.w ├── running_mean_std.scm ├── running_mean_std.w ├── say.scm ├── say.w ├── securepassword.corpus ├── securepassword.scm ├── securepassword.w ├── sh.scm ├── sh.w ├── string-replace-benchmark.scm ├── string-replace-benchmark.w ├── threaded-writing.w ├── timeit.w ├── tinyenc.c ├── tinyenc.scm ├── tinyenc.w ├── triangle.w ├── unbiased-std.scm ├── unbiased-std.w ├── unicode-math-fun.scm ├── unicode-math-fun.w ├── upload-server.scm ├── upload-server.w ├── with.scm ├── with.w ├── y-combinator.scm ├── y-combinator.w ├── yinyang.scm └── yinyang.w ├── gpl.txt ├── guildhall-packages └── newbase60 │ ├── newbase60.scm │ └── pkg-list.scm ├── m4 └── guile.m4 ├── ob-wisp.el ├── racket ├── parse.rkt └── wisp.rkt ├── testrunner.w ├── tests ├── btest.scm ├── btest.w ├── continuation.scm ├── continuation.w ├── dotted-pair.scm ├── dotted-pair.w ├── emacs-customization-tex-master.scm ├── emacs-customization-tex-master.w ├── emacs-customization.scm ├── emacs-customization.w ├── example.scm ├── example.w ├── factorial.scm ├── factorial.w ├── fast-sum.scm ├── fast-sum.w ├── flexible-parameter-list.scm ├── flexible-parameter-list.w ├── hello.scm ├── hello.w ├── linebreaks.scm ├── literalarray.scm ├── literalarray.w ├── mtest.scm ├── mtest.w ├── multiline-string.scm ├── multiline-string.w ├── namedlet.scm ├── namedlet.w ├── partial-indent.scm ├── partial-indent.w ├── quotecolon.scm ├── quotecolon.w ├── range.scm ├── range.w ├── readable-tests.scm ├── readable-tests.w ├── realpath.sh ├── receive.scm ├── receive.w ├── runtests-scheme-preprocessor.sh ├── runtests-scheme-reader.sh ├── runtests-scripts.sh ├── self-referencial.scm ├── self-referencial.w ├── shebang.scm ├── shebang.w ├── strangecomments.scm ├── strangecomments.w ├── sublist.scm ├── sublist.w ├── sxml.scm ├── sxml.w ├── syntax-colon.scm ├── syntax-colon.w ├── syntax-dot.scm ├── syntax-dot.w ├── syntax-empty.scm ├── syntax-empty.w ├── syntax-indent.scm ├── syntax-indent.w ├── syntax-strings-parens.scm ├── syntax-strings-parens.w ├── syntax-underscore.scm └── syntax-underscore.w ├── wisp-guile.w ├── wisp-mode.el ├── wisp-multiline.sh ├── wisp-reader.w ├── wisp-repl-guile.sh ├── wisp-scheme.w ├── wisp.in └── wisp.py /.bugs/details/499afb16915b64d56aff710d292b46ddaa060869.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | 13 | [expected] 14 | # The expected result 15 | 16 | 17 | [actual] 18 | # What happened instead 19 | 20 | 21 | [reproduce] 22 | # Reproduction steps 23 | wget https://bitbucket.org/ArneBab/wisp/downloads/wisp-0.9.6.tar.gz; 24 | tar xf wisp-0.9.6.tar.gz ; cd wisp-0.9.6/; 25 | ./configure; make check; 26 | examples/newbase60.w 123 27 | 28 | ^ shows compilation errors which go away after a short guile ... -c '(import (language wisp spec))' 29 | 30 | [comments] 31 | # Comments and updates - leave your name 32 | -------------------------------------------------------------------------------- /.bugs/details/4d4e76343fe09f0ec72a3e5eb0077bd16e12f9d5.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | after the fix: 12 | wisp-scheme now passes the testsuite, tested by a testrunner which checks the code-tree, not the string-representation. 13 | 14 | 15 | [expected] 16 | # The expected result 17 | 18 | 19 | [actual] 20 | # What happened instead 21 | 22 | 23 | [reproduce] 24 | # Reproduction steps 25 | 26 | 27 | [comments] 28 | # Comments and updates - leave your name 29 | -------------------------------------------------------------------------------- /.bugs/details/6749f3abcb9455eac9271efd8265797bce114239.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | Needed: 12 | 13 | - square brackets for RSR6 and 14 | - curly braces for curly-infix. 15 | 16 | Both should simply disable wisp-parsing inside them. 17 | 18 | [expected] 19 | # The expected result 20 | 21 | 22 | [actual] 23 | # What happened instead 24 | 25 | 26 | [reproduce] 27 | # Reproduction steps 28 | 29 | 30 | [comments] 31 | # Comments and updates - leave your name 32 | Discussion: 33 | 34 | does it need to support square brackets? 35 | (foo [bar 5])? 36 | well, R6RS mandates that [] are equivalent to (). 37 | but of course, you are inventing a new syntax, so it's up to you. 38 | then I’ll have to add support for that, I think. 39 | IMO, it would be good to support SRFI-105 curly-infix notation. 40 | wisp is just a preprocessor to regular scheme-code, so pasting any valid scheme in beween should work. 41 | well, specifically, I think you should pass anything between curly braces unchanged. 42 | just as you do with parens, I guess. 43 | yes 44 | <-- fangism (~davidfang@209.119.54.132) hat das Netzwerk verlassen (Remote host closed the connection) 45 | curly infix can be combined with datum labels too, so you can have #0={...} 46 | that should still work as soon as I have curly braces. 47 | and of course, expressions delimited by curly braces can span multiple lines. 48 | so actually it boils down to treating parens, square brackets and curly braces in the same way (but they can be nested). 49 | almos the same… 50 | almost 51 | (foo [bar {5 + 6 ] }) ← nasty syntax error? 52 | yes 53 | can you see any cases where this would not be a syntax error? 54 | no 55 | then I could just treat parens, brackets and braces as abstract delimiters and not worry about the difference… 56 | But I worry that such a simplification could break badly 57 | well, if curly-infix mode is not enabled in the reader (and it's off by default), then '{' and '}' are not delimiters and can be part of unescaped symbols. 58 | ouch… 59 | but curly-infix mode is turned on automatically if "#!curly-infix" is present in the file. 60 | --> int3__ (~int3__@175.156.240.23) hat #guile betreten 61 | but I wouldn't worry too much about edge cases like this. I think it's likely that your reader has a number of other problems with edge cases like this. 62 | I guess that’s true… 63 | it's not practical to get it exactly right without somehow integrating it into guile's native reader. 64 | (though the version written in wisp is a good deal more versatile than the bootstrap version in python ☺) 65 | you'd have to exactly match the detailed syntax understood by guile's reader, which is a moving target and has some complex nooks and crannies. 66 | for that matter, guile's reader is also extensible. 67 | -------------------------------------------------------------------------------- /.bugs/details/7a57614fa920b2ddad002d044b144d0bb7c34f84.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | 13 | [expected] 14 | # The expected result 15 | 16 | 17 | [actual] 18 | # What happened instead 19 | 20 | 21 | [reproduce] 22 | # Reproduction steps 23 | 24 | 25 | [comments] 26 | # Comments and updates - leave your name 27 | This will require restructuring of the parsing to stay maintainable. Deferred for now. 28 | 29 | For notes how to do it right, see http://draketo.de/light/english/recursion-wins 30 | -------------------------------------------------------------------------------- /.bugs/details/8cf6202873d4454f57813dd17cf60432059f7c62.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | 13 | [expected] 14 | # The expected result 15 | 16 | 17 | [actual] 18 | # What happened instead 19 | 20 | 21 | [reproduce] 22 | # Reproduction steps 23 | 24 | 25 | [comments] 26 | # Comments and updates - leave your name 27 | This will require restructuring of the parsing to stay maintainable. Deferred for now. 28 | 29 | For notes how to do it right, see http://draketo.de/light/english/recursion-wins 30 | -------------------------------------------------------------------------------- /.bugs/details/91bcbbe2453226a053e02b84601cc22f43087b29.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | this breaks: 13 | 14 | values 15 | ' : content-type . (text/plain) 16 | . "Hello hacker!" 17 | 18 | this also breaks: 19 | 20 | values 21 | ' : content-type . : text/plain 22 | . "Hello hacker!" 23 | 24 | this works: 25 | 26 | values 27 | ' (content-type . (text/plain)) 28 | . "Hello hacker!" 29 | 30 | 31 | [expected] 32 | # The expected result 33 | 34 | 35 | [actual] 36 | # What happened instead 37 | 38 | 39 | [reproduce] 40 | # Reproduction steps 41 | 42 | 43 | [comments] 44 | # Comments and updates - leave your name 45 | -------------------------------------------------------------------------------- /.bugs/details/ce28d6c0d1f9894c9b946e56b17934473800edfe.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | see tests/strangecomments.w tests/strangecomments.scm 8 | 9 | [details] 10 | # Additional details 11 | 12 | 13 | [expected] 14 | # The expected result 15 | 16 | 17 | [actual] 18 | # What happened instead 19 | 20 | 21 | [reproduce] 22 | # Reproduction steps 23 | 24 | 25 | [comments] 26 | # Comments and updates - leave your name 27 | -------------------------------------------------------------------------------- /.bugs/details/d6de2074a5017f1f29f34d142ce797981ed270a0.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | Don’t do this: It would make it impossible to just past in lisp code, so it would break backwards compatibility. See http://sourceforge.net/mailarchive/message.php?msg_id=30755324 and the associated thread for reasoning. 12 | 13 | 14 | [expected] 15 | # The expected result 16 | 17 | 18 | [actual] 19 | # What happened instead 20 | 21 | 22 | [reproduce] 23 | # Reproduction steps 24 | 25 | 26 | [comments] 27 | # Comments and updates - leave your name 28 | -------------------------------------------------------------------------------- /.bugs/details/d9147504868960e5fbc2648474d48ce5c9bd1a02.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | 13 | [expected] 14 | # The expected result 15 | 16 | 17 | [actual] 18 | # What happened instead 19 | 20 | 21 | [reproduce] 22 | # Reproduction steps 23 | echo "define ; ) 24 | a ' : b 25 | " | ./wisp.py - 26 | 27 | [comments] 28 | # Comments and updates - leave your name 29 | -------------------------------------------------------------------------------- /.bugs/details/e445b9ed2403cd366e556f384129c08970f0b77a.txt: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | This is a collection of problems connected to quoting. 13 | 14 | 15 | ` ,(+ 1 2) ,(+ 2 3) , : + 4 5 16 | 17 | should be equivalent to 18 | 19 | `(,(+ 1 2) ,(+ 2 3) ,(+ 4 5)) 20 | 21 | but gives 22 | 23 | (REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd (unquote (+ 1 2)) (unquote (+ 2 3)) (unquote (+ 4 5)) 24 | 25 | this works: 26 | 27 | ` ,(+ 1 2) ,(+ 2 3) : , + 4 5 28 | 29 | display ` , : + 1 30 | should give (display `(,(+ 1))) 31 | but gives (display `(,((+ 1)))) 32 | 33 | [expected] 34 | # The expected result 35 | 36 | 37 | [actual] 38 | # What happened instead 39 | 40 | 41 | [reproduce] 42 | # Reproduction steps 43 | 44 | 45 | [comments] 46 | # Comments and updates - leave your name 47 | -------------------------------------------------------------------------------- /.bugs/details/e445b9ed2403cd366e556f384129c08970f0b77a.txt.orig: -------------------------------------------------------------------------------- 1 | # Lines starting with '#' and sections without content 2 | # are not displayed by a call to 'details' 3 | # 4 | [paths] 5 | # Paths related to this bug. 6 | # suggested format: REPO_PATH:LINENUMBERS 7 | 8 | 9 | [details] 10 | # Additional details 11 | 12 | This is a collection of problems connected to quoting. 13 | 14 | 15 | 16 | ` ,(+ 1 2) ,(+ 2 3) , : + 4 5 17 | 18 | should be equivalent to 19 | 20 | `(,(+ 1 2) ,(+ 2 3) ,(+ 4 5)) 21 | 22 | but gives 23 | 24 | (REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd (unquote (+ 1 2)) (unquote (+ 2 3)) (unquote (+ 4 5)) 25 | 26 | this works: 27 | 28 | ` ,(+ 1 2) ,(+ 2 3) : , + 4 5 29 | 30 | display ` , : + 1 31 | should give (display `(,(+ 1))) 32 | but gives (display `(,((+ 1)))) 33 | 34 | 35 | 36 | [expected] 37 | # The expected result 38 | 39 | 40 | [actual] 41 | # What happened instead 42 | 43 | 44 | [reproduce] 45 | # Reproduction steps 46 | 47 | 48 | [comments] 49 | # Comments and updates - leave your name 50 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 220ce60600a7424ec2a167c6c4174b1e43570738 v0.1 2 | d72216a3aeab91f60f0004264e329fc636da32b6 v0.2 3 | 60b1c42aae9b4bcef8a3fa1a3e8da04770efa641 v0.3 4 | 5698a4f0fd7090c234732e1dacf38eb3c996f807 v0.3.1 5 | 0509e9e3418789ef307ae49b7dd862380c5c5bf8 v0.4 6 | c5c1f8a58c298f6894ed4386e9df6866a7e629a2 v0.5 7 | ce8ccd40ef936710e76200d2ee138535e4ab0fb4 v0.5.1 8 | 00de78a95055f846906d57b1a094a1c3e6bb2dbd v0.5.2 9 | df64e82e0920bdd079d77cd4829bac9d30461a25 v0.5.3 10 | f9c6e637d91d107bbf2ad807f30dc04150ddb251 v0.5.4 11 | 3f72f85e4cddf57e5e6c84c735f554f330d3b88b v0.5.5 12 | 2ae2c7c154e0c80acd21bdb2dace1c98a0a8d7a7 v0.5.6 13 | fb1b0fb41bc768485f582f3f5af16478aa6212a1 v0.5.7 14 | efd0ee6e65c3948e0c643526063029b691424de8 v0.5.8 15 | bb1c4165b8a6d12929625e6518a5b1c727c75942 v0.5.9 16 | 0e1335f015a83c6c6616019189c665b3849269ce v0.5.10 17 | 07ec05365e84d29d24ce5f476654f9542931ed2d v0.5.11 18 | 9af37e8efa7a2674caec07c7d2339f136f380d37 wisp-mode-0.2 19 | 5475d743562512c44d2cdd0bf534c78c88efb0f8 v0.6.0 20 | 64745a296d569849de536000b636c100e3e0d30c v0.6.1 21 | 7089c2ba36f5b3f1eeafde42be4ca4e4df1d6544 v0.6.2 22 | fc3d17fe770257a5e700c912844cee14668aa431 v0.6.3 23 | 1c63ac211fe4275a00f7e206c7f44051e0d7cd81 v0.6.4 24 | 42ab97d010efa7883240f5e5254ea46fd9423239 v0.6.5 25 | b7441736af4dc8f1a7df860d1b064e080a45e1a5 v0.6.6 26 | 0e702c268e6fdc9c52f034b6553c940b09c16400 v0.8.0 27 | 8eaf023f5d3bc20ad4b795cde3a92e3b5c242dba v0.8.1 28 | 327acbae68ef4efbf77734f0ee20359ed559ce0d v0.8.2 29 | 41c48043ca33bf47311a93d0545b13a0578c3cf0 v0.8.3 30 | a4bca2a0f2f6659d97b1db471ae9803119b80529 v0.8.4 31 | f0096bf5f3baee5017be94f49c70515fe2a535b3 wisp-mode-0.2.1 32 | fb551bbe7084d22ef0c8e35df3864eb2aef46005 v0.8.5 33 | 625eec6805f907b9d6338d09c8199e9ed3e79ab1 v0.8.6 34 | e6977cfff0c8e0d2b1b33f724e0e4607ea15f703 v0.8.7 35 | cb0b13b613cbd3c39f5384ea85a570fee2bb3569 v0.9.0 36 | 2614197d8be8d9c7cdc00b4ce225f74524b66716 v0.9.1 37 | 40595e956e7d267625accf9d5584bae88466b41a v0.9.2 38 | 7a6f1a55af314540efb68e109b9d15ccdfddeb96 v0.9.3 39 | b536803e2a7ce03e08088861e4f663dfcb2a01ea v0.9.4 40 | 5559a51f3d32539e4ff6d182b5c514fb6ecc495a v0.9.5 41 | 167fa001cabbf80d2d6a9d570a989227e0dbccc1 v0.9.6 42 | 56044ce725b7d803100d58881e60e63668b6edb8 v0.9.7 43 | 7a00652f014f83e39f08236b90d98a94e201e59b v0.9.8 44 | 08957fca134a456a644a53ca5d758d10befbfd03 v0.9.9 45 | 1e6fac92905c2ca4d7fcd83cfc4d5347ccd19197 v0.9.9.1 46 | ca4e089b6d1f26aa3626490191438c9e26995701 v1.0 47 | 3a527b81edb429775eedada34d0466304a6ea43e v1.0.1 48 | 92559bb0e31251b35837fde64c534e5bc3753911 v1.0.2 49 | ba80bf370de0fe4867fc6ace066fa54af65f73d0 v1.0.3 50 | 0ab387918c68c420fad357c7d1c504881adcd696 wisp-mode-0.2.7 51 | 6e5925471629f1fcea8ffb31fbce77a8dc244394 v1.0.4 52 | 91b69da97645da9d40c4223af97c00edfe20ed70 wisp-mode-0.2.8 53 | 67df1796d2c3251835935ac4031b4b364c9f9ffa wisp-mode-0.2.9 54 | 6a5c7fdb2c826ee5dc0c61fc12840b34107a7cd8 v1.0.5 55 | c0dc6cd3e21cabc0681448f506b7d7f5e82de06e v1.0.6 56 | 3c9e708df324289f39ada9f1f8beae7e7a84f326 v1.0.7 57 | 8692cfb048383133e38bdbf5a594b426b6c339f3 wisp-mode-0.3.0 58 | 49630734fdd8dcee906ce405b1ca406b43c34040 v1.0.8 59 | 0ac5f8ecc77387fa931b5a13659458eea5a7fac2 v1.0.9 60 | 072fb89d39e33418cb48fa5d25d50545b03f4db0 v1.0.10 61 | 13e6fbf177e04153159a137168c880d3bc0d56e6 v1.0.11 62 | 7c6239a779656cd55225ad24e15cc29bc896f834 v1.0.12 63 | -------------------------------------------------------------------------------- /AUTHORS.in: -------------------------------------------------------------------------------- 1 | Main Author: Arne Babenhauserheide 2 | 3 | Specific Contributions: 4 | 5 | - Maxime Devos: cleaner encoding and reader handling and unlimited underscores 6 | - Mark Weaver and Arne Babenhauserheide: Efficient string-replace-substring 7 | - Mark Weaver and NalaGinrut and Arne Babenhauserheide: wisp-reader.w 8 | - Christine Lemmer Webber added functions to interact with geiser, now 9 | included in wisp-mode as wisp--eval-with-geiser and wisp--wisp2lisp 10 | 11 | Authors Info: 12 | 13 | Arne Babenhauserheide: 14 | Arne Babenhauserheide known as ArneBab: http://savannah.gnu.org/users/arnebab 15 | 16 | NalaGinrut: 17 | "Mu Lei" known as "NalaGinrut" : http://savannah.gnu.org/users/nalaginrut 18 | 19 | Mark Weaver: 20 | Mark H. Weaver: http://savannah.gnu.org/users/mhw 21 | 22 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /bootstrap-reader.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | if [[ x"$1" == x"" ]]; then 4 | srcdir=. 5 | else 6 | srcdir="$1" 7 | fi 8 | 9 | if [[ x"$2" == x"" ]]; then 10 | builddir=. 11 | else 12 | builddir="$2" 13 | fi 14 | 15 | 16 | if [[ x"$3" == x"" ]]; then 17 | guile='guile' 18 | else 19 | guile="$3" 20 | fi 21 | 22 | 23 | if test -f wisp.scm; then 24 | wisp=wisp.scm 25 | elif test -f "${builddir}/wisp.scm"; then 26 | wisp="${builddir}/wisp.scm" 27 | else 28 | wisp="${srcdir}/wisp.scm" 29 | fi 30 | 31 | 32 | mkdir -p ${builddir}/language/wisp 33 | 34 | echo ";;;" preparing the reader: wisp at the REPL 1>&2 35 | 36 | echo ";;;" parsing wisp-scheme.w with the parser for the REPL 1>&2 37 | ${guile} ${wisp} ${srcdir}/wisp-scheme.w 2>/dev/null > ${builddir}/language/wisp.scm \ 38 | && echo ";;;" ...precompiling the parser... 1>&2 \ 39 | && ${guile} -s ${builddir}/language/wisp.scm 2>/dev/null \ 40 | && echo ";;;" ...succeeded 1>&2 \ 41 | || echo creating language/wisp.scm failed 42 | 43 | echo ";;;" parsing the spec file... 1>&2 44 | ${guile} ${wisp} ${srcdir}/wisp-reader.w 2>/dev/null > ${builddir}/language/wisp/spec.scm \ 45 | && echo ";;;" ...precompiling the spec file... 1>&2 \ 46 | && ${guile} -L . -s ${builddir}/language/wisp/spec.scm \ 47 | && echo ";;;" ...succeeded 1>&2 \ 48 | && echo ";;;" to use wisp at the REPL, run '`'${guile} -L . --language=wisp'`' 1>&2 \ 49 | || echo creating language/wisp/spec.scm failed 50 | 51 | -------------------------------------------------------------------------------- /bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Bootstrap wisp-guile with wisp.py 4 | if [[ x"$1" == x"" ]]; then 5 | srcdir=. 6 | else 7 | srcdir="$1" 8 | fi 9 | 10 | # Bootstrap wisp-guile with wisp.py 11 | if [[ x"$2" == x"" ]]; then 12 | guile='guile' 13 | else 14 | guile="$2" 15 | fi 16 | 17 | # Bootstrap wisp-guile with wisp.py 18 | if [[ x"$3" == x"" ]]; then 19 | python3="python3" 20 | else 21 | python3="$3" 22 | fi 23 | 24 | diff=$(${python3} ${srcdir}/wisp.py ${srcdir}/wisp-guile.w > 1 && ${guile} 1 ${srcdir}/wisp-guile.w > 2 && ${guile} 2 ${srcdir}/wisp-guile.w > wisp.scm && diff 2 wisp.scm && echo success) 25 | if [[ ! x"${diff}" == x"success" ]]; then 26 | echo "failed to bootstrap wisp.scm. diff: " ${diff} 27 | exit 1 28 | fi 29 | # put all output into stderr via 1>&2 and prefix it with ;;; to make it possible to kill it alongside the auto-compile output from guile with one sed. 30 | echo ";;;" "successfully bootstrapped wisp.scm" 1>&2 31 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | dnl run `autoreconf -i` to generate a configure script. 2 | dnl Then run ./configure to generate a Makefile. 3 | dnl Finally run make to generate the project. 4 | AC_INIT([wisp], [1.0.12], 5 | [arne_bab@web.de]) 6 | # Add macros in m4/ to ensure that wisp builds without having Guile in the aclocal path 7 | AC_CONFIG_MACRO_DIR([m4]) 8 | 9 | # Check for programs I need for my build 10 | AC_CANONICAL_TARGET 11 | 12 | # search for Guile using the guile m4 files. 13 | # see https://www.gnu.org/software/guile/manual/html_node/Autoconf-Macros.html 14 | # This provides @GUILE@ to Makefile.am 15 | GUILE_PKG([3.0 2.2 2.0 1.8]) 16 | GUILE_PROGS 17 | GUILE_SITE_DIR 18 | 19 | dnl set installation prefix for language file to Guile location 20 | AC_PREFIX_PROGRAM([guile]) 21 | 22 | AC_ARG_VAR([python3], [How to call Python 3.]) 23 | AC_CHECK_TARGET_TOOL([python3], [python3], [no]) 24 | AS_IF([test "x$python3" = "xno"], 25 | [AC_MSG_WARN([cannot find Python 3 which is required for development bootstrapping.])]) 26 | 27 | # Is this a normal install, or a "make distcheck"? We need to disable 28 | # the tests in a "make distcheck" that won't work. 29 | # FIXME: automake should honor DESTDIR set by make distcheck 30 | is_make_distcheck=no 31 | AS_CASE([$prefix], 32 | [*/_inst], 33 | [AC_MSG_NOTICE([[Prefix ends in /_inst; this is a 'make distcheck'.]]) 34 | is_make_distcheck=yes]) 35 | AM_CONDITIONAL([IS_MAKE_DISTCHECK], [test "x$is_make_distcheck" = x"yes"]) 36 | AC_MSG_CHECKING([final decision IS_MAKE_DISTCHECK (running "make distcheck"?)]) 37 | AM_COND_IF([IS_MAKE_DISTCHECK], [AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) 38 | 39 | # Run automake 40 | # Use GNU style. Note that ChangeLog is created on every commit 41 | # by a commit hook in .hg/hgrc 42 | # [hooks] 43 | # post-commit = hg log --style changelog > ChangeLog 44 | AM_INIT_AUTOMAKE([gnu]) 45 | AM_MAINTAINER_MODE([enable]) 46 | AC_CONFIG_FILES([Makefile]) 47 | AC_CONFIG_LINKS([tests/realpath.sh:tests/realpath.sh]) 48 | 49 | AC_OUTPUT 50 | -------------------------------------------------------------------------------- /docs/handwritten-code.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/docs/handwritten-code.jpg -------------------------------------------------------------------------------- /docs/interactive-run.txt: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | guile -L . --language=wisp << EOF 3 | 4 | display "Hello World!\n" . 5 | 6 | define : hello 7 | display "Hello World!" 8 | newline . 9 | 10 | hello . 11 | 12 | define-syntax-rule : hello who 13 | format #t "Hello ~A!\n" (symbol->string 'who) 14 | 15 | 16 | hello World . 17 | 18 | define-syntax-rule : welcome-to what 19 | format #t "Welcome to ~A!\n" : symbol->string 'what . 20 | 21 | welcome-to Wisp . 22 | 23 | define-syntax-rule : welcome-to . what 24 | format #t "Welcome to ~A!\n" 25 | string-join : map symbol->string 'what . 26 | 27 | welcome-to syntax like Python with the simplicity and power of Lisp . 28 | 29 | display 'http://draketo.de/english/wisp 30 | newline 31 | EOF 32 | -------------------------------------------------------------------------------- /docs/srfi-119/README: -------------------------------------------------------------------------------- 1 | SRFI-119 supporting files 2 | ========================= 3 | 4 | 5 | Bootstrap wisp using Python 3 6 | ----------------------------- 7 | 8 | sh bootstrap.sh 9 | 10 | This creates wisp-preprocessor.scm (the version in the tarball is called wisp-guile.scm to avoid overwriting it) 11 | and wisp-parser.scm (the version in the tarball is called wisp-scheme.scm) 12 | 13 | 14 | Description 15 | ----------- 16 | 17 | wisp-preprocessor.scm reads files in wisp-syntax and outputs generic scheme. 18 | 19 | usage: guile wisp-preprocessor.scm > 20 | 21 | wisp-parser.scm provides procedures for reading s-expressions from wisp-files. 22 | 23 | -------------------------------------------------------------------------------- /docs/srfi-119/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Bootstrap wisp using Python 3 4 | 5 | # This creates wisp-preprocessor.scm (the version in the tarball is called wisp-guile.scm to avoid overwriting it) 6 | # and wisp-parser.scm (the version in the tarball is called wisp-scheme.scm) 7 | 8 | # usage: guile wisp-preprocessor.scm > 9 | 10 | # wisp-parser.scm provides procedures for reading s-expressions from wisp-files. 11 | 12 | python3 wisp.py wisp-guile.w > 1 \ 13 | && guile 1 wisp-guile.w > 2 \ 14 | && guile 2 wisp-guile.w > wisp-preprocessor.scm \ 15 | && diff 2 wisp-preprocessor.scm \ 16 | && guile wisp-preprocessor.scm wisp-scheme.w > wisp-parser.scm \ 17 | && rm 1 2 18 | 19 | -------------------------------------------------------------------------------- /docs/tutorial.org: -------------------------------------------------------------------------------- 1 | - for devs from other languages: the only line terminator is the newline. ; starts a comment till the end of the line. 2 | -------------------------------------------------------------------------------- /docs/ui/default/blank.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/docs/ui/default/blank.gif -------------------------------------------------------------------------------- /docs/ui/default/bodybg.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/docs/ui/default/bodybg.gif -------------------------------------------------------------------------------- /docs/ui/default/framing.css: -------------------------------------------------------------------------------- 1 | /* The following styles size, place, and layer the slide components. 2 | Edit these if you want to change the overall slide layout. 3 | The commented lines can be uncommented (and modified, if necessary) 4 | to help you with the rearrangement process. */ 5 | 6 | /* target = 1024x768 */ 7 | 8 | div#header, div#footer, .slide {width: 100%; top: 0; left: 0;} 9 | div#header {top: 0; height: 3em; z-index: 1;} 10 | div#footer {top: auto; bottom: 0; height: 2.5em; z-index: 5;} 11 | .slide {top: 0; width: 92%; padding: 3.5em 4% 4%; z-index: 2; list-style: none;} 12 | div#controls {left: 50%; bottom: 0; width: 50%; z-index: 100;} 13 | div#controls form {position: absolute; bottom: 0; right: 0; width: 100%; 14 | margin: 0;} 15 | #currentSlide {position: absolute; width: 10%; left: 45%; bottom: 1em; z-index: 10;} 16 | html>body #currentSlide {position: fixed;} 17 | 18 | /* 19 | div#header {background: #FCC;} 20 | div#footer {background: #CCF;} 21 | div#controls {background: #BBD;} 22 | div#currentSlide {background: #FFC;} 23 | */ 24 | -------------------------------------------------------------------------------- /docs/ui/default/iepngfix.htc: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 42 | -------------------------------------------------------------------------------- /docs/ui/default/opera.css: -------------------------------------------------------------------------------- 1 | /* DO NOT CHANGE THESE unless you really want to break Opera Show */ 2 | .slide { 3 | visibility: visible !important; 4 | position: static !important; 5 | page-break-before: always; 6 | } 7 | #slide0 {page-break-before: avoid;} 8 | -------------------------------------------------------------------------------- /docs/ui/default/outline.css: -------------------------------------------------------------------------------- 1 | /* don't change this unless you want the layout stuff to show up in the outline view! */ 2 | 3 | .layout div, #footer *, #controlForm * {display: none;} 4 | #footer, #controls, #controlForm, #navLinks, #toggle { 5 | display: block; visibility: visible; margin: 0; padding: 0;} 6 | #toggle {float: right; padding: 0.5em;} 7 | html>body #toggle {position: fixed; top: 0; right: 0;} 8 | 9 | /* making the outline look pretty-ish */ 10 | 11 | #slide0 h1, #slide0 h2, #slide0 h3, #slide0 h4 {border: none; margin: 0;} 12 | #slide0 h1 {padding-top: 1.5em;} 13 | .slide h1 {margin: 1.5em 0 0; padding-top: 0.25em; 14 | border-top: 1px solid #888; border-bottom: 1px solid #AAA;} 15 | #toggle {border: 1px solid; border-width: 0 0 1px 1px; background: #FFF;} 16 | -------------------------------------------------------------------------------- /docs/ui/default/pretty.css: -------------------------------------------------------------------------------- 1 | /* Following are the presentation styles -- edit away! */ 2 | 3 | body {background: #FFF url(bodybg.gif) -16px 0 no-repeat; color: #000; font-size: 2em;} 4 | :link, :visited {text-decoration: none; color: #00C;} 5 | #controls :active {color: #88A !important;} 6 | #controls :focus {outline: 1px dotted #227;} 7 | h1, h2, h3, h4 {font-size: 100%; margin: 0; padding: 0; font-weight: inherit;} 8 | ul, pre {margin: 0; line-height: 1em;} 9 | html, body {margin: 0; padding: 0;} 10 | 11 | blockquote, q {font-style: italic;} 12 | blockquote {padding: 0 2em 0.5em; margin: 0 1.5em 0.5em; text-align: center; font-size: 1em;} 13 | blockquote p {margin: 0;} 14 | blockquote i {font-style: normal;} 15 | blockquote b {display: block; margin-top: 0.5em; font-weight: normal; font-size: smaller; font-style: normal;} 16 | blockquote b i {font-style: italic;} 17 | 18 | kbd {font-weight: bold; font-size: 1em;} 19 | sup {font-size: smaller; line-height: 1px;} 20 | 21 | .slide code {padding: 2px 0.25em; font-weight: bold; color: #533;} 22 | .slide code.bad, code del {color: red;} 23 | .slide code.old {color: silver;} 24 | .slide pre {padding: 0; margin: 0.25em 0 0.5em 0.5em; color: #533; font-size: 90%;} 25 | .slide pre code {display: block;} 26 | .slide ul {margin-left: 5%; margin-right: 7%; list-style: disc;} 27 | .slide li {margin-top: 0.75em; margin-right: 0;} 28 | .slide ul ul {line-height: 1;} 29 | .slide ul ul li {margin: .2em; font-size: 85%; list-style: square;} 30 | .slide img.leader {display: block; margin: 0 auto;} 31 | 32 | div#header, div#footer {background: #005; color: #AAB; 33 | font-family: Verdana, Helvetica, sans-serif;} 34 | div#header {background: #005 url(bodybg.gif) -16px 0 no-repeat; 35 | line-height: 1px;} 36 | div#footer {font-size: 0.5em; font-weight: bold; padding: 1em 0;} 37 | #footer h1, #footer h2 {display: block; padding: 0 1em;} 38 | #footer h2 {font-style: italic;} 39 | 40 | div.long {font-size: 0.75em;} 41 | .slide h1 {position: absolute; top: 0.7em; left: 87px; z-index: 1; 42 | margin: 0; padding: 0.3em 0 0 50px; white-space: nowrap; 43 | font: bold 150%/1em Helvetica, sans-serif; text-transform: capitalize; 44 | color: #DDE; background: #005;} 45 | .slide h3 {font-size: 130%;} 46 | h1 abbr {font-variant: small-caps;} 47 | 48 | div#controls {position: absolute; left: 50%; bottom: 0; 49 | width: 50%; 50 | text-align: right; font: bold 0.9em Verdana, Helvetica, sans-serif;} 51 | html>body div#controls {position: fixed; padding: 0 0 1em 0; 52 | top: auto;} 53 | div#controls form {position: absolute; bottom: 0; right: 0; width: 100%; 54 | margin: 0; padding: 0;} 55 | #controls #navLinks a {padding: 0; margin: 0 0.5em; 56 | background: #005; border: none; color: #779; 57 | cursor: pointer;} 58 | #controls #navList {height: 1em;} 59 | #controls #navList #jumplist {position: absolute; bottom: 0; right: 0; background: #DDD; color: #227;} 60 | 61 | #currentSlide {text-align: center; font-size: 0.5em; color: #449;} 62 | 63 | #slide0 {padding-top: 3.5em; font-size: 90%;} 64 | #slide0 h1 {position: static; margin: 1em 0 0; padding: 0; 65 | font: bold 2em Helvetica, sans-serif; white-space: normal; 66 | color: #000; background: transparent;} 67 | #slide0 h2 {font: bold italic 1em Helvetica, sans-serif; margin: 0.25em;} 68 | #slide0 h3 {margin-top: 1.5em; font-size: 1.5em;} 69 | #slide0 h4 {margin-top: 0; font-size: 1em;} 70 | 71 | ul.urls {list-style: none; display: inline; margin: 0;} 72 | .urls li {display: inline; margin: 0;} 73 | .note {display: none;} 74 | .external {border-bottom: 1px dotted gray;} 75 | html>body .external {border-bottom: none;} 76 | .external:after {content: " \274F"; font-size: smaller; color: #77B;} 77 | 78 | .incremental, .incremental *, .incremental *:after {color: #DDE; visibility: visible;} 79 | img.incremental {visibility: hidden;} 80 | .slide .current {color: #B02;} 81 | 82 | 83 | /* diagnostics 84 | 85 | li:after {content: " [" attr(class) "]"; color: #F88;} 86 | */ -------------------------------------------------------------------------------- /docs/ui/default/print.css: -------------------------------------------------------------------------------- 1 | /* The following rule is necessary to have all slides appear in print! DO NOT REMOVE IT! */ .slide, ul {page-break-inside: avoid; visibility: visible !important;} h1 {page-break-after: avoid;} body {font-size: 12pt; background: white;} * {color: black;} #slide0 h1 {font-size: 200%; border: none; margin: 0.5em 0 0.25em;} #slide0 h3 {margin: 0; padding: 0;} #slide0 h4 {margin: 0 0 0.5em; padding: 0;} #slide0 {margin-bottom: 3em;} h1 {border-top: 2pt solid gray; border-bottom: 1px dotted silver;} .extra {background: transparent !important;} div.extra, pre.extra, .example {font-size: 10pt; color: #333;} ul.extra a {font-weight: bold;} p.example {display: none;} #header {display: none;} #footer h1 {margin: 0; border-bottom: 1px solid; color: gray; font-style: italic;} #footer h2, #controls {display: none;} /* The following rule keeps the layout stuff out of print. Remove at your own risk! */ .layout, .layout * {display: none !important;} -------------------------------------------------------------------------------- /docs/ui/default/s5-core.css: -------------------------------------------------------------------------------- 1 | /* Do not edit or override these styles! The system will likely break if you do. */ 2 | 3 | div#header, div#footer, div#controls, .slide {position: absolute;} 4 | html>body div#header, html>body div#footer, 5 | html>body div#controls, html>body .slide {position: fixed;} 6 | .handout {display: none;} 7 | .layout {display: block;} 8 | .slide, .hideme, .incremental {visibility: hidden;} 9 | #slide0 {visibility: visible;} 10 | -------------------------------------------------------------------------------- /docs/ui/default/slides.css: -------------------------------------------------------------------------------- 1 | @import url(s5-core.css); /* required to make the slide show run at all */ 2 | @import url(framing.css); /* sets basic placement and size of slide components */ 3 | @import url(pretty.css); /* stuff that makes the slides look better than blah */ -------------------------------------------------------------------------------- /docs/ui/i18n/00_head.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /docs/ui/i18n/bg-shade.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/docs/ui/i18n/bg-shade.png -------------------------------------------------------------------------------- /docs/ui/i18n/bg-slide.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/docs/ui/i18n/bg-slide.jpg -------------------------------------------------------------------------------- /docs/ui/i18n/framing.css: -------------------------------------------------------------------------------- 1 | /* The following styles size and place the slide components. 2 | Edit them if you want to change the overall slide layout. 3 | The commented lines can be uncommented (and modified, if necessary) 4 | to help you with the rearrangement process. */ 5 | 6 | div#header, div#footer, .slide {width: 100%; top: 0; left: 0;} 7 | div#header {top: 0; left: 0; z-index: 1;} 8 | div#footer {top: auto; bottom: 0; width: 100%; z-index: 5;} 9 | .slide {top: 0; width: 88%; padding: 1em 7% 2em 5%; z-index: 2;} 10 | 11 | div#controls {bottom: 1em; left: 0; width: 100%; text-align: center; z-index: 1000;} 12 | div#controls form {margin: 0; padding: 0;} 13 | 14 | #currentSlide {position: absolute; left: 0; bottom: 0.5em; z-index: 10; 15 | width: 100%; text-align: center;} 16 | html>body #currentSlide {position: fixed;} 17 | 18 | /* 19 | div#header {background: #FCC;} 20 | div#footer {background: #CCF;} 21 | div#controls {background: #BBD;} 22 | div#currentSlide {background: #FFC;} 23 | */ 24 | -------------------------------------------------------------------------------- /docs/ui/i18n/pretty.css: -------------------------------------------------------------------------------- 1 | /* 2 | Theme: i18n 3 | Eric A. Meyer (http://meyerweb.com/) 4 | Theme placed under CC by-sa 2.0 license 5 | */ 6 | 7 | body {background: #95A7D4 url(bg-slide.jpg) 100% 100% no-repeat; color: #210; font: 28px Arial, sans-serif;} 8 | a {text-decoration: none; color: #336; border-bottom: 1px dotted;} 9 | h1, h2, h3, h4, h5, h6 {font-size: 1em; margin: 0;} 10 | sup {font-size: 0.75em; font-weight: normal; 11 | vertical-align: 0.5em; line-height: 1px;} 12 | ul {margin-left: 1em; padding-left: 0;} 13 | li {margin-bottom: 0.66em;} 14 | li li {margin: 0.33em 0; font-size: smaller;} 15 | 16 | #header {background: url(bg-shade.png); border-bottom: 1px solid #333; 17 | padding-bottom: 2em;} 18 | #footer {background: url(bg-shade.png); color: #BBB; border-top: 1px solid #333;} 19 | #header, #footer {font-size: 0.5em;} 20 | #footer h1, #footer h2 { padding: 0.5em 0.75em; 21 | font-weight: normal; font-style: italic;} 22 | #footer h1 {left: 0; font-size: 1em; letter-spacing: 1px;} 23 | #footer h2 {position: absolute; bottom: 0; right: 0;} 24 | 25 | #controls {font-size: 0.75em;} 26 | #navList {margin-top: 3px;} 27 | #navLinks a {margin: 0 0.33em; padding: 0 0.25em; 28 | border: 1px solid; border-color: #CCD #556 #556 #CCD; 29 | background-color: #8597C4;} 30 | 31 | #currentSlide {font-size: 0.5em;} 32 | #currentSlide span {font-size: 13px; color: rgb(49%,47%,66%);} 33 | #currentSlide #csSep {display: none;} 34 | #currentSlide #csHere {font-weight: bold;} 35 | #currentSlide #csHere:before {content: "#"; font-weight: normal;} 36 | #currentSlide #csTotal:before {content: " of ";} 37 | 38 | .slide h1 {font-size: 1.66em; line-height: 1; letter-spacing: -1px; 39 | margin: 0 -15% 1em 0; padding: 0.5em 15% 0.06125em 0; border-bottom: 0.06125em solid rgb(90,94,120);} 40 | #slide0 h1 {border: none; font-size: 2.25em; letter-spacing: 0; margin: 3em 0 1.5em;} 41 | #slide0 h3 {margin: 0.5em 0 0;} 42 | #slide0 h4 {margin-top: 0; font-size: smaller;} 43 | 44 | .slide .current {color: #003; text-shadow: 0 0 0.25em #9AABD7;} 45 | -------------------------------------------------------------------------------- /docs/ui/i18n/s5-core.css: -------------------------------------------------------------------------------- 1 | /* Do not edit or override these styles! The system will likely break if you do. */ 2 | 3 | div#header, div#footer, div#controls, div.slide {position: absolute;} 4 | html>body div#header, html>body div#footer, 5 | html>body div#controls, html>body div.slide {position: fixed;} 6 | .handout {display: none;} 7 | .layout {display: block;} 8 | div.slide, .hideme, .incremental {visibility: hidden;} 9 | #slide0 {visibility: visible;} 10 | -------------------------------------------------------------------------------- /docs/ui/i18n/slides.css: -------------------------------------------------------------------------------- 1 | @import url(s5-core.css); /* required to make the slide show run at all */ 2 | @import url(framing.css); /* sets basic placement and size of slide components */ 3 | @import url(pretty.css); /* stuff that makes the slides look better than blah */ -------------------------------------------------------------------------------- /docs/ui/org-slides.js: -------------------------------------------------------------------------------- 1 | function formatSlideTitle(i) { 2 | var a = $('

').append($('').append($(this).contents())); 3 | $(this).replaceWith(a); 4 | } 5 | 6 | const tagTranslator = { 7 | "Incremental": "incremental", 8 | "ShowFirst": "show-first", 9 | }; 10 | 11 | function interpretTags() { 12 | $("h1 span.tag span").each(function(){ 13 | $(this).parent().parent().parent() 14 | .siblings().children("ul") 15 | .addClass(tagTranslator[$(this).text()]); 16 | }); 17 | $("li span.tag span").each(function(){ 18 | $(this).parent() 19 | .siblings("ul") 20 | .addClass(tagTranslator[$(this).text()]); 21 | }); 22 | $("span.tag").remove(); 23 | } 24 | 25 | function rewriteExternalLinks() { 26 | $("a").each(function(){ 27 | if ($(this).attr("href").match("^http://")) 28 | $(this).attr("rel", "external"); 29 | }); 30 | } 31 | 32 | $(document).ready(function () { 33 | $("div.outline-2").addClass("slide"); 34 | $("div.slide h2").each(formatSlideTitle); 35 | interpretTags(); 36 | rewriteExternalLinks(); 37 | }); 38 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | tinyenc : tinyenc.c 2 | gcc -Wall -O3 tinyenc.c -o tinyenc 3 | -------------------------------------------------------------------------------- /examples/advent-2016-day-7.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/examples/advent-2016-day-7.scm -------------------------------------------------------------------------------- /examples/argparse.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples argparse) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | ;; Argument parser 8 | ;; 9 | ;; Status: draft (basic interface works, but does not do something useful yet) 10 | ;; 11 | ;; plan: (TODO) 12 | ;; - simplest usage: (import (examples argparse))(let ((args (parse-args))) (write args)) 13 | ;; - with setup: (import (examples argparse)) 14 | ;; (let* ((parser (setup-args #:help "foo")) 15 | ;; (args (parse-args #:parser parser))) 16 | ;; (write args)) 17 | ;; - implement -h | --help | --usage and -V | --version, set up automatically and improved via setup-args. 18 | 19 | (define-module (examples argparse) 20 | #:export (args-parse args-setup)) 21 | 22 | (import (ice-9 optargs)) 23 | 24 | (define* (args-parse #:optional args #:key parser) 25 | (if (equal? #f args) 26 | (command-line) 27 | args)) 28 | 29 | (define* (args-setup #:key (help #f)) 30 | #f) 31 | 32 | (define (main args) 33 | (let ((args (args-parse args))) 34 | (write args)) 35 | (let* 36 | ((parser (args-setup #:help "argparse")) 37 | (args (args-parse #:parser parser))) 38 | (write args)) 39 | (let* 40 | ((parser (args-setup #:help "argparse")) 41 | (args (args-parse args #:parser parser))) 42 | (write args))) 43 | 44 | 45 | -------------------------------------------------------------------------------- /examples/argparse.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples argparse)' -c '' "$@" 5 | ; !# 6 | 7 | ;; Argument parser 8 | ;; 9 | ;; Status: draft (basic interface works, but does not do something useful yet) 10 | ;; 11 | ;; plan: (TODO) 12 | ;; - simplest usage: (import (examples argparse))(let ((args (args-parse))) (write args)) 13 | ;; - with setup: (import (examples argparse)) 14 | ;; (let* ((parser (setup-args #:help "foo")) 15 | ;; (args (parse-args #:parser parser))) 16 | ;; (write args)) 17 | ;; - implement -h | --help | --usage and -V | --version, set up automatically and improved via setup-args. 18 | 19 | define-module : examples argparse 20 | . #:export : args-parse args-setup main 21 | 22 | import : ice-9 optargs 23 | 24 | define* : args-parse #:optional args #:key parser 25 | if : equal? #f args 26 | command-line 27 | . args 28 | 29 | define* : args-setup #:key (help #f) 30 | . #f 31 | 32 | define : main args 33 | let : : args : args-parse args 34 | write args 35 | let* 36 | : parser : args-setup #:help "argparse" 37 | args : args-parse #:parser parser 38 | write args 39 | let* 40 | : parser : args-setup #:help "argparse" 41 | args : args-parse args #:parser parser 42 | write args 43 | -------------------------------------------------------------------------------- /examples/bits-as-numberstring.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples bits-as-numberstring)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples bits-as-numberstring 8 | . #:export : main 9 | 10 | import : examples doctests 11 | srfi srfi-1 ; list operations 12 | srfi srfi-37 ; commandline parsing 13 | srfi srfi-60 ; bit conversion via integer->list 14 | rnrs bytevectors 15 | rnrs io ports 16 | ice-9 match 17 | ice-9 format 18 | ice-9 rdelim ; for read-string 19 | ice-9 binary-ports 20 | ice-9 pretty-print 21 | 22 | format : current-error-port 23 | . "THIS CODE HAS SERIOUS ISSUES with the bits->bytes->hammingencode->bits->bytes->hammingdecode->bits due to byte-bits-alignment, except if the number of checkbits is a multiple of 8. 16 to 31 chara" 24 | 25 | define : read-file filepath 26 | let* 27 | : port : open-input-file filepath 28 | data : get-bytevector-all port 29 | close port 30 | . data 31 | 32 | define : write-file filepath bytevector 33 | let* 34 | : port : open-output-file filepath 35 | put-bytevector port bytevector 36 | close port 37 | 38 | 39 | define : u8->bits u8 40 | ## tests : test-equal '(#t #f #f #f #f #f #t #t) : u8->bits 131 41 | let loop 42 | : bits : list 43 | remaining u8 44 | pow2 128 45 | cond 46 | {pow2 < 1} 47 | reverse bits 48 | {remaining > pow2} 49 | loop : cons #t bits 50 | . {remaining - pow2} 51 | / pow2 2 52 | else 53 | loop : cons #f bits 54 | . remaining 55 | / pow2 2 56 | 57 | 58 | define : bytevector->bits bv 59 | let loop 60 | : bits : list 61 | bytes : bytevector->u8-list bv 62 | cond 63 | : null? bytes 64 | . bits 65 | else 66 | loop : append bits : integer->list (first bytes) 8 67 | cdr bytes 68 | 69 | define : bits->bytevector bits 70 | let loop 71 | : bytes : list 72 | bits bits 73 | cond 74 | : null? bits 75 | u8-list->bytevector : reverse! bytes 76 | {(length bits) < 8} ;; zero-pad;; FIXME: This is wrong, somewhere there is a bug here. 77 | let : : bits : append bits : make-list {8 - (length bits)} #f 78 | loop 79 | cons : list->integer : take bits 8 80 | . bytes 81 | drop bits 8 82 | else 83 | loop 84 | cons : list->integer : take bits 8 85 | . bytes 86 | drop bits 8 87 | 88 | define : bits->numbers bits 89 | map : lambda (x) : if x 1 0 90 | . bits 91 | 92 | define : numbers->bits numbers 93 | map : lambda (x) : if (equal? x 0) #f #t 94 | . numbers 95 | 96 | 97 | define : bitlist->bitstring bitlist 98 | string-join : map number->string bitlist 99 | . "" 100 | 101 | define : encode infile outfile 102 | ;; pretty-print : bits->bytevector : numbers->bits : bits->numbers : bytevector->bits : read-file filepath 103 | write-file outfile 104 | string->bytevector ;; write 0 and 1 as letters 105 | bitlist->bitstring : bits->numbers : bytevector->bits : read-file infile 106 | native-transcoder 107 | newline 108 | 109 | 110 | define : decode infile outfile 111 | pretty-print : read-file infile 112 | display : bitlist->bitstring : bits->numbers : bytevector->bits : read-file infile 113 | newline 114 | write-file outfile ;; write bits 115 | bits->bytevector 116 | map : λ (x) (if (equal? x #\0) #f #t) 117 | string->list : bytevector->string (read-file infile) : native-transcoder 118 | 119 | define %this-module : current-module 120 | define : main args 121 | when : null? : cdr args 122 | doctests-testmod %this-module 123 | exit 0 124 | when {(length args) < 3} 125 | format : current-error-port 126 | . "must have at least one argument, but got ~a" : cdr args 127 | exit 1 128 | if : equal? "-D" : second args 129 | decode (third args) (fourth args) 130 | encode (second args) (third args) 131 | -------------------------------------------------------------------------------- /examples/cartesian-sets.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples cartesian-sets) main)' -s "$0" "$@") 5 | ; !# 6 | ;; Implementation of the cartesian product over a list of lists, building on http://stackoverflow.com/a/20591545/7666 7 | 8 | (define-module (examples cartesian-sets) 9 | #:export (cartesian-product)) 10 | 11 | (import (srfi srfi-1)) 12 | 13 | ;; original 14 | (define (cartesian-product-lambda . lists) 15 | (fold-right 16 | (lambda (xs ys) 17 | (append-map (lambda (x) 18 | (map (lambda (y) 19 | (cons x y)) 20 | ys)) 21 | xs)) 22 | '(()) 23 | lists)) 24 | 25 | 26 | ;; easier to understand 27 | (define (cartesian-product . lists) 28 | (define (product-of-two xs ys) 29 | (define (cons-on-each-ys x) 30 | (map (lambda (y) (cons x y)) 31 | ys)) 32 | (append-map cons-on-each-ys 33 | xs)) 34 | (fold-right product-of-two '(()) lists)) 35 | 36 | (define (main args) 37 | (write (cartesian-product-lambda '(1 2) '(3 4) '(5 6))) 38 | (newline) 39 | (write (cartesian-product '(1 2) '(3 4) '(5 6))) 40 | (newline)) 41 | 42 | 43 | -------------------------------------------------------------------------------- /examples/cartesian-sets.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples cartesian-sets)' -c '' "$@" 5 | ; !# 6 | ;; Implementation of the cartesian product over a list of lists, building on http://stackoverflow.com/a/20591545/7666 7 | 8 | define-module : examples cartesian-sets 9 | . #:export : cartesian-product main 10 | 11 | import : srfi srfi-1 12 | 13 | ;; original 14 | define : cartesian-product-lambda . lists 15 | fold-right 16 | lambda : xs ys 17 | append-map (lambda (x) 18 | (map (lambda (y) 19 | (cons x y)) 20 | ys)) 21 | . xs 22 | . '(()) 23 | . lists 24 | 25 | 26 | ;; easier to understand 27 | define : cartesian-product . lists 28 | define : product-of-two xs ys 29 | define : cons-on-each-ys x 30 | map : lambda (y) (cons x y) 31 | . ys 32 | append-map cons-on-each-ys 33 | . xs 34 | fold-right product-of-two '(()) lists 35 | 36 | define : main args 37 | write : cartesian-product-lambda '(1 2) '(3 4) '(5 6) 38 | newline 39 | write : cartesian-product '(1 2) '(3 4) '(5 6) 40 | newline 41 | -------------------------------------------------------------------------------- /examples/cholesky.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples cholesky) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | ;; Cholesky decomposition, following https://de.wikipedia.org/wiki/Cholesky-Zerlegung#Pseudocode 8 | 9 | (define-module (examples cholesky) 10 | #:export (cholesky! matrix-ref matrix-set! matrix-transpose matrix-multiply)) 11 | 12 | (use-modules (srfi srfi-42 ); list-comprehension 13 | (srfi srfi-11 )); let-values 14 | 15 | (define (->exact-matrix list-of-lists) 16 | "Turn a list of lists into a matrix" 17 | (map 18 | (λ (x) 19 | (apply list (map inexact->exact x))) 20 | list-of-lists)) 21 | 22 | (define (->inexact-matrix list-of-lists) 23 | "Turn a list of lists into a matrix" 24 | (map 25 | (λ (x) 26 | (apply list (map exact->inexact x))) 27 | list-of-lists)) 28 | 29 | (define (matrix-ref X row col) 30 | (list-ref (list-ref X row) col)) 31 | 32 | (define (matrix-set! X row col val) 33 | (let ((sublist (list-ref X row))) 34 | (list-set! sublist col val) 35 | (list-set! X row sublist))) 36 | 37 | (define (matrix-transpose X) 38 | "Swap columns and rows of a matrix" 39 | (list-ec (: outer (length X)) ; outer 40 | (list-ec (: inner (length (list-ref X outer))) ; inner 41 | (matrix-ref X inner outer)))) 42 | 43 | (define (matrix-multiply X Y) 44 | "Calculate the matrix product of X and Y" 45 | (list-ec (: row (length Y)) 46 | (list-ec (: col (length X)) 47 | (sum-ec (: inner (length (list-ref Y row))) 48 | (* (matrix-ref Y inner col) 49 | (matrix-ref X row inner)))))) 50 | 51 | (define (mostly-exact-sqrt n) 52 | "Calculate an exact sqrt if possible, else use a good approximation" 53 | (inexact->exact (sqrt (inexact->exact n)))) 54 | 55 | (define (cholesky! a) 56 | "Modifies the square matrix a to contain its cholesky decomposition. 57 | 58 | sets a to g with a = ggT, 59 | 60 | a is represented as list of lists." 61 | (let ((n (length a))) 62 | (do-ec (: i n) 63 | (do-ec (: j (+ 1 i)) 64 | (let ((sum (matrix-ref a i j))) 65 | ; format #t "n: ~A i: ~A j: ~A\n" n i j 66 | (when (>= j 1) 67 | (do-ec (: k j) 68 | (set! sum (- sum (* (matrix-ref a i k) (matrix-ref a j k)))))) 69 | (cond 70 | ((> i j ); lower triangle 71 | (matrix-set! a i j 72 | (/ sum 73 | (matrix-ref a j j)))) 74 | ((> sum 0 ); diagonal element 75 | (matrix-set! a i i 76 | (mostly-exact-sqrt sum ))); preserves the exactness, since the result is an exact number, though not an exact result 77 | (else 78 | (throw 'matrix-numerically-not-symmetric-positive-definite a)))))) 79 | (do-ec (: i n) 80 | (do-ec (: j (+ 1 i) n) 81 | (matrix-set! a i j 0))) 82 | a)) 83 | 84 | 85 | (define (main args) 86 | (let 87 | (( X (->exact-matrix '(( 1 -1 1) 88 | (-1 3 -.5) 89 | ( 1 -.5 4)))) 90 | (L (->exact-matrix '(( 1 0 0) 91 | (-1 1.41421356 0) 92 | ( 1 0.35355339 1.6955825))))) 93 | (format #t "X\n") 94 | (display (->inexact-matrix X)) 95 | (newline) 96 | (format #t "cholesky\n") 97 | (display (->inexact-matrix (cholesky! X))) 98 | (newline) 99 | (format #t "L\n") 100 | (display (->inexact-matrix L)) 101 | (newline) 102 | (format #t "L·Lt\n") 103 | (display 104 | (->inexact-matrix 105 | (matrix-multiply L (matrix-transpose L)))) 106 | (newline) 107 | (format #t "X·Xt\n") 108 | (display 109 | (->inexact-matrix 110 | (matrix-multiply X (matrix-transpose X)))) 111 | (newline))) 112 | 113 | 114 | -------------------------------------------------------------------------------- /examples/cholesky.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples cholesky)' -c '' "$@" 5 | ; !# 6 | 7 | ;; Cholesky decomposition, following https://de.wikipedia.org/wiki/Cholesky-Zerlegung#Pseudocode 8 | 9 | define-module : examples cholesky 10 | . #:export : cholesky! matrix-ref matrix-set! matrix-transpose matrix-multiply main 11 | 12 | use-modules : srfi srfi-42 ; list-comprehension 13 | srfi srfi-11 ; let-values 14 | 15 | define : ->exact-matrix list-of-lists 16 | . "Turn a list of lists into a matrix" 17 | map 18 | λ : x 19 | apply list : map inexact->exact x 20 | . list-of-lists 21 | 22 | define : ->inexact-matrix list-of-lists 23 | . "Turn a list of lists into a matrix" 24 | map 25 | λ : x 26 | apply list : map exact->inexact x 27 | . list-of-lists 28 | 29 | define : matrix-ref X row col 30 | list-ref (list-ref X row) col 31 | 32 | define : matrix-set! X row col val 33 | let : : sublist : list-ref X row 34 | list-set! sublist col val 35 | list-set! X row sublist 36 | 37 | define : matrix-transpose X 38 | . "Swap columns and rows of a matrix" 39 | list-ec (: outer (length X)) ; outer 40 | list-ec (: inner (length (list-ref X outer))) ; inner 41 | matrix-ref X inner outer 42 | 43 | define : matrix-multiply X Y 44 | . "Calculate the matrix product of X and Y" 45 | list-ec (: row (length Y)) 46 | list-ec (: col (length X)) 47 | sum-ec (: inner (length (list-ref Y row))) 48 | * : matrix-ref Y inner col 49 | matrix-ref X row inner 50 | 51 | define : mostly-exact-sqrt n 52 | . "Calculate an exact sqrt if possible, else use a good approximation" 53 | inexact->exact : sqrt : inexact->exact n 54 | 55 | define : cholesky! a 56 | . "Modifies the square matrix a to contain its cholesky decomposition. 57 | 58 | sets a to g with a = ggT, 59 | 60 | a is represented as list of lists." 61 | let : : n : length a 62 | do-ec (: i n) 63 | do-ec (: j (+ 1 i)) 64 | let : : sum : matrix-ref a i j 65 | ; format #t "n: ~A i: ~A j: ~A\n" n i j 66 | when : >= j 1 67 | do-ec (: k j) 68 | set! sum : - sum : * (matrix-ref a i k) (matrix-ref a j k) 69 | cond 70 | : > i j ; lower triangle 71 | matrix-set! a i j 72 | / sum 73 | matrix-ref a j j 74 | : > sum 0 ; diagonal element 75 | matrix-set! a i i 76 | mostly-exact-sqrt sum ; preserves the exactness, since the result is an exact number, though not an exact result 77 | else 78 | throw 'matrix-numerically-not-symmetric-positive-definite a 79 | do-ec (: i n) 80 | do-ec (: j (+ 1 i) n) 81 | matrix-set! a i j 0 82 | . a 83 | 84 | 85 | define : main args 86 | let 87 | : X : ->exact-matrix '(( 1 -1 1) 88 | (-1 3 -.5) 89 | ( 1 -.5 4)) 90 | L : ->exact-matrix '(( 1 0 0) 91 | (-1 1.41421356 0) 92 | ( 1 0.35355339 1.6955825)) 93 | format #t "X\n" 94 | display : ->inexact-matrix X 95 | newline 96 | format #t "cholesky\n" 97 | display : ->inexact-matrix : cholesky! X 98 | newline 99 | format #t "L\n" 100 | display : ->inexact-matrix L 101 | newline 102 | format #t "L·Lt\n" 103 | display 104 | ->inexact-matrix 105 | matrix-multiply L : matrix-transpose L 106 | newline 107 | format #t "X·Xt\n" 108 | display 109 | ->inexact-matrix 110 | matrix-multiply X : matrix-transpose X 111 | newline 112 | -------------------------------------------------------------------------------- /examples/cli.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples cli) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | (define-module (examples cli) 8 | #:use-module (ice-9 match)) 9 | 10 | (define (main args) 11 | (match args 12 | ((prog ); just the program name, empty call 13 | (display (car args))) 14 | (else 15 | (display args))) 16 | (newline)) 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /examples/cli.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples cli)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples cli 8 | . #:use-module : ice-9 match 9 | . #:export : main 10 | 11 | define : main args 12 | match args 13 | : prog ; just the program name, empty call 14 | display : car args 15 | else 16 | display args 17 | newline 18 | 19 | -------------------------------------------------------------------------------- /examples/closure.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples closure) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | ;; A simple example for a closure 8 | 9 | 10 | (define counting-closure ; simple variable 11 | (let ((counter 0 )); provide counter to hold local data 12 | (lambda () ; the variable is bound to a function -> callable 13 | (set! counter (1+ counter )); adjust the counter shared by all function calls 14 | counter))) 15 | 16 | 17 | ; counter is created outside the function definition (lambda), so the 18 | ; change survives over function calls. It is function-local data. 19 | 20 | 21 | (define (main args) 22 | (display (counting-closure)) 23 | (newline ); 1 24 | (display (counting-closure)) 25 | (newline ); 2 26 | (display (counting-closure)) 27 | (newline )); 3 28 | 29 | 30 | -------------------------------------------------------------------------------- /examples/closure.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples closure)' -c '' "$@" 5 | ; !# 6 | 7 | ;; A simple example for a closure 8 | 9 | define-module : examples closure 10 | . #:export : main 11 | 12 | define counting-closure ; simple variable 13 | let : : counter 0 ; provide counter to hold local data 14 | lambda () ; the variable is bound to a function -> callable 15 | set! counter : 1+ counter ; adjust the counter shared by all function calls 16 | . counter 17 | 18 | 19 | ; counter is created outside the function definition (lambda), so the 20 | ; change survives over function calls. It is function-local data. 21 | 22 | 23 | define : main args 24 | display : counting-closure 25 | newline ; 1 26 | display : counting-closure 27 | newline ; 2 28 | display : counting-closure 29 | newline ; 3 30 | -------------------------------------------------------------------------------- /examples/coffee.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | ;;; coffee --- pseudo-code for work with coffee, based on flawed java-code on a cup 8 | 9 | (import (ice-9 q) 10 | (ice-9 pretty-print)) 11 | 12 | (define-syntax-rule (sip x) 13 | (set! x #f)) 14 | (define-syntax-rule (pop x) 15 | (let ((y (car x))) 16 | (set! x (cdr x)) 17 | y)) 18 | 19 | (define* (work schedule) 20 | (let* 21 | ((pot (prepare 'coffee)) 22 | (cup (serve pot))) 23 | (let proceed ((task (pop schedule))) 24 | (sip cup) 25 | (execute task) 26 | (when (not (done? schedule)) 27 | (when (empty? cup) 28 | (when (empty? pot) 29 | (set! pot (prepare 'coffee))) 30 | (set! cup (serve pot))) 31 | (proceed (pop schedule)))))) 32 | 33 | (define prepare list) 34 | (define serve car) 35 | (define execute pretty-print) 36 | (define done? null?) 37 | (define (empty? x) 38 | (equal? #f x)) 39 | (define schedule (iota 5)) 40 | 41 | (work schedule) 42 | 43 | 44 | -------------------------------------------------------------------------------- /examples/coffee.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@" 5 | ; !# 6 | 7 | ;;; coffee --- pseudo-code for work with coffee, based on flawed java-code on a cup 8 | 9 | import : ice-9 q 10 | ice-9 pretty-print 11 | 12 | define-syntax-rule : sip x 13 | set! x #f 14 | define-syntax-rule : pop x 15 | let : : y : car x 16 | set! x : cdr x 17 | . y 18 | 19 | define* : work schedule 20 | let* 21 | : pot : prepare 'coffee 22 | cup : serve pot 23 | let proceed : : task : pop schedule 24 | sip cup 25 | execute task 26 | when : not : done? schedule 27 | when : empty? cup 28 | when : empty? pot 29 | set! pot : prepare 'coffee 30 | set! cup : serve pot 31 | proceed : pop schedule 32 | 33 | define prepare list 34 | define serve car 35 | define execute pretty-print 36 | define done? null? 37 | define : empty? x 38 | equal? #f x 39 | define schedule : iota 5 40 | 41 | work schedule 42 | -------------------------------------------------------------------------------- /examples/comment-server.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | (use-modules 8 | (web server) 9 | (web request) 10 | (web response) 11 | (web uri) 12 | (rnrs unicode) 13 | (rnrs bytevectors )); for utf8->string 14 | 15 | (define (header-html) 16 | '((content-type . (text/html)))) 17 | 18 | (define (show-comments request comments-hash-table) 19 | (let* 20 | ((path (uri-path (request-uri request))) 21 | (uri-components (split-and-decode-uri-path path))) 22 | (string-join 23 | (list "Comments
24 | 25 | 26 |
" 27 | (hash-ref comments-hash-table uri-components 28 | (string-join uri-components ));; default 29 | "\n")))) 30 | 31 | (define (change-comment-content current to-add) 32 | (if current 33 | (string-join (list "
" to-add "
" current)) 34 | (string-join (list "
" to-add "
")))) 35 | 36 | (define (body->comment request-body) 37 | (let ((request-string (utf8->string request-body))) 38 | (substring request-string 39 | (string-length "comment=") 40 | (string-index request-string #\& )))); This is just a mockup. 41 | 42 | (define (add-comment request request-body comments-hash-table) 43 | (let ((uri-components (split-and-decode-uri-path (uri-path (request-uri request))))) 44 | (hash-set! comments-hash-table uri-components 45 | (change-comment-content 46 | (hash-ref comments-hash-table uri-components) 47 | (body->comment request-body))) 48 | (show-comments request comments-hash-table))) 49 | 50 | 51 | (define global-comment-hash-table (make-hash-table)) 52 | 53 | (define (uri-comment-showing-handler request request-body) 54 | (values 55 | (header-html) 56 | (if request-body 57 | (add-comment request request-body global-comment-hash-table) 58 | (show-comments request global-comment-hash-table)))) 59 | 60 | (display "Server starting. Test it at http://127.0.0.1:8083 61 | Hit CTRL-C twice to stop the server. 62 | ") 63 | 64 | (run-server uri-comment-showing-handler 'http '(#:port 8083)) 65 | 66 | 67 | -------------------------------------------------------------------------------- /examples/comment-server.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples comment-server)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples comment-server 8 | . #:export : main 9 | 10 | use-modules 11 | web server 12 | web request 13 | web response 14 | web uri 15 | rnrs unicode 16 | rnrs bytevectors ; for utf8->string 17 | 18 | define : header-html 19 | ' : content-type . : text/html 20 | 21 | define : show-comments request comments-hash-table 22 | let* 23 | : path : uri-path : request-uri request 24 | uri-components : split-and-decode-uri-path path 25 | string-join 26 | list "Comments
27 | 28 | 29 |
" 30 | hash-ref comments-hash-table uri-components 31 | string-join uri-components ;; default 32 | . "\n" 33 | 34 | define : change-comment-content current to-add 35 | if current 36 | string-join : list "
" to-add "
" current 37 | string-join : list "
" to-add "
" 38 | 39 | define : body->comment request-body 40 | let : : request-string : utf8->string request-body 41 | substring request-string 42 | string-length "comment=" 43 | string-index request-string #\& ; This is just a mockup. 44 | 45 | define : add-comment request request-body comments-hash-table 46 | let : : uri-components : split-and-decode-uri-path : uri-path : request-uri request 47 | hash-set! comments-hash-table uri-components 48 | change-comment-content 49 | hash-ref comments-hash-table uri-components 50 | body->comment request-body 51 | show-comments request comments-hash-table 52 | 53 | 54 | define global-comment-hash-table : make-hash-table 55 | 56 | define : uri-comment-showing-handler request request-body 57 | values 58 | header-html 59 | if request-body 60 | add-comment request request-body global-comment-hash-table 61 | show-comments request global-comment-hash-table 62 | 63 | 64 | define : main args 65 | display "Server starting. Test it at http://127.0.0.1:8083 66 | Hit CTRL-C twice to stop the server. 67 | " 68 | 69 | run-server uri-comment-showing-handler 'http ' : #:port 8083 70 | -------------------------------------------------------------------------------- /examples/d6.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples d6) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | (define-module (examples d6) 8 | #:export (roll check)) 9 | 10 | (use-modules (srfi srfi-1)) 11 | 12 | ; basic d6 rules, implemented in guile 13 | 14 | (define (roll) 15 | "Roll one ± d6" 16 | (let* 17 | ((eyes '(-5 -3 -1 2 4 6)) 18 | (d6 (lambda () (list-ref eyes (random 6 (random-state-from-platform)))))) 19 | (let rolling ((rolled (cons (d6) '()))) 20 | (cond 21 | ((= 1 (length rolled)) 22 | (if (not (member (first rolled) '(-5 6))) 23 | (values (first rolled) (first rolled)) 24 | (rolling (cons (d6) rolled)))) 25 | ((not (equal? (first rolled) (second rolled))) 26 | (values (apply + (cdr rolled)) (first rolled))) 27 | (else 28 | (rolling (cons (d6) rolled))))))) 29 | 30 | 31 | (define (check skill target effect-threshold) 32 | "Check whether a given skill-roll succeeds and provide a margin of success." 33 | (let ((result (+ skill (roll)))) 34 | (if (> result target) 35 | (floor/ {result - target} effect-threshold) 36 | #f))) 37 | 38 | (define (main args) 39 | (display (check 12 9 3)) 40 | (newline) 41 | (newline) 42 | (display (roll))) 43 | 44 | 45 | -------------------------------------------------------------------------------- /examples/d6.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples d6)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples d6 8 | . #:export : roll check main 9 | 10 | use-modules : srfi srfi-1 11 | 12 | ; basic d6 rules, implemented in guile 13 | 14 | define : roll 15 | . "Roll one ± d6" 16 | let* 17 | : eyes '(-5 -3 -1 2 4 6) 18 | d6 : lambda () : list-ref eyes : random 6 : random-state-from-platform 19 | let rolling : : rolled : cons (d6) '() 20 | cond 21 | : = 1 (length rolled) 22 | if : not : member (first rolled) '(-5 6) 23 | values 24 | first rolled 25 | first rolled 26 | rolling : cons (d6) rolled 27 | : not : equal? (first rolled) (second rolled) 28 | values 29 | apply + : cdr rolled 30 | first rolled 31 | else 32 | rolling : cons (d6) rolled 33 | 34 | 35 | 36 | define : check skill target effect-threshold 37 | . "Check whether a given skill-roll succeeds and provide a margin of success." 38 | let : : result : + skill : roll 39 | if : > result target 40 | floor/ {result - target} effect-threshold 41 | . #f 42 | 43 | define : main args 44 | display : check 12 9 3 45 | newline 46 | newline 47 | display : roll 48 | -------------------------------------------------------------------------------- /examples/doctests-test.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # -*- scheme -*- 3 | exec guile -L $(dirname $(dirname $(realpath "$0"))) -e '(@@ (examples doctests-test) main)' -s "$0" "$@" 4 | ; !# 5 | 6 | (define-module (examples doctests-test)) 7 | 8 | (import (examples doctests)) 9 | 10 | (define (foo) 11 | #((tests 12 | ('foo 13 | (test-equal "bar" (foo))))) 14 | "bar") 15 | 16 | (define %this-module (current-module)) 17 | (define (main args) 18 | "Testing doctests" 19 | #((tests ('mytest 20 | (test-assert #t) 21 | (test-assert #f)))) 22 | (doctests-testmod %this-module)) 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /examples/doctests-test.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples doctests-test)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples doctests-test 8 | . #:export : main 9 | 10 | import : examples doctests 11 | 12 | define : foo 13 | ## 14 | tests 15 | 'foo-equality-tests 16 | test-equal "bar" : foo 17 | test-equal "bar" "bar" 18 | test-equal 'bar : string->symbol : foo 19 | test-equal 'foo 'foo 20 | . "bar" 21 | 22 | define %this-module : current-module 23 | define : main args 24 | . " Testing doctests" 25 | . #((tests ('mytest 26 | (test-assert #t) 27 | (test-assert #f)))) 28 | doctests-testmod %this-module 29 | 30 | -------------------------------------------------------------------------------- /examples/doctests-testone.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # -*- scheme -*- 3 | exec guile -L $(dirname $(dirname $(realpath "$0"))) -s "$0" "$@" 4 | ; !# 5 | 6 | (import (examples doctests)) 7 | 8 | (define (foo) 9 | #((tests 10 | ('foo 11 | (test-equal "bar" (foo))))) 12 | "bar") 13 | 14 | (doctests-testmod (current-module)) 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /examples/doctestss-testone.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | exec guile -L $(dirname $(dirname $(realpath "$0"))) -s "$0" "$@" 3 | ; !# 4 | 5 | (import (examples doctests)) 6 | 7 | (define (one) 8 | "(test 'one 9 | (test-equal 1 (one)))" 10 | 1) 11 | 12 | (doctests-testmod (current-module)) 13 | -------------------------------------------------------------------------------- /examples/duel.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (D="$(dirname $(realpath "$0"))" 4 | W="$(dirname $(dirname $(realpath "$0")))" 5 | guile -L "$W" -c '(import (language wisp spec))') 6 | (exec guile -L "$W" --language=wisp -l "$D/enter-three-witches.w" -s "$0" "$@") 7 | ; !# 8 | 9 | (import (examples enter-three-witches)) 10 | 11 | (set! *random-state* (random-state-from-platform)) 12 | 13 | (Enter (Galtag Nimbleday) 14 | (Lowlife Pirate) 15 | (choose your answer)) 16 | 17 | (define challenges 18 | `( 19 | ((You fight like a Dairy Farmer!) 20 | (How appropriate! You fight like a cow!) 21 | (And I've got a little TIP for you, get the POINT?)))) 22 | 23 | ; write answers 24 | ; newline 25 | 26 | (define (random-challenge) 27 | (list-ref challenges (random (length challenges)))) 28 | 29 | (define (list->textline L) 30 | (string-join (map ->string L) 31 | " ")) 32 | 33 | ;; TODO: define-syntax define-interaction 34 | (define (duel me other) 35 | (let* 36 | ((challenge (random-challenge)) 37 | (tease (car challenge)) 38 | (answers (map list->textline (cdr challenge)))) 39 | (say-name other) 40 | (say-words 41 | ((,@tease))) 42 | (say-name '(choose your answer)) 43 | ;; TODO: shuffle the answers, check whether the right one is given 44 | ;; (the first answer in the original ordering is the right one) 45 | (say-words 46 | ((,(let ((counter 0)) 47 | (string-join 48 | (map (λ (x) 49 | (set! counter (+ 1 counter)) 50 | (string-append (number->string counter) " " x)) answers) "\n "))))) 51 | (let 52 | ((answer (list-ref answers (- (string->number (format #f "~a" (peek-char))) 1)))) 53 | (drain-input (current-input-port)) 54 | (say-name me) 55 | (say-words 56 | ((,answer)))))) 57 | 58 | 59 | (define-syntax-rule (Duel fighter1 fighter2) 60 | (duel 61 | (quote fighter1) 62 | (quote fighter2))) 63 | 64 | 65 | (Duel 66 | (Galtag Nimbleday) 67 | (Lowlife Pirate)) 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /examples/duel.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | D="$(dirname $(realpath "$0"))" 4 | W="$(dirname $(dirname $(realpath "$0")))" 5 | guile -L "$W" -c '(import (language wisp spec))' 6 | exec -a "$0" guile -L "$W" --language=wisp -x .w -e '(examples duel)' -c '' "$@" 7 | ; !# 8 | 9 | define-module : examples duel 10 | . #:export : main 11 | 12 | import : examples enter-three-witches 13 | 14 | set! *random-state* : random-state-from-platform 15 | 16 | Enter : Galtag Nimbleday 17 | Lowlife Pirate 18 | choose your answer 19 | 20 | define challenges 21 | ` 22 | : You fight like a Dairy Farmer! 23 | How appropriate! You fight like a cow! 24 | And I've got a little TIP for you, get the POINT? 25 | 26 | ; write answers 27 | ; newline 28 | 29 | define : random-challenge 30 | list-ref challenges : random : length challenges 31 | 32 | define : list->textline L 33 | string-join : map ->string L 34 | . " " 35 | 36 | ;; TODO: define-syntax define-interaction 37 | define : duel me other 38 | let* 39 | : challenge : random-challenge 40 | tease : car challenge 41 | answers : map list->textline : cdr challenge 42 | say-name other 43 | say-words 44 | : ,@tease 45 | say-name ' : choose your answer 46 | ;; TODO: shuffle the answers, check whether the right one is given 47 | ;; (the first answer in the original ordering is the right one) 48 | say-words 49 | : ,(let ((counter 0)) 50 | (string-join 51 | (map (λ (x) 52 | (set! counter (+ 1 counter)) 53 | (string-append (number->string counter) " " x)) answers) "\n ")) 54 | let 55 | : answer : list-ref answers (- (string->number (format #f "~a" (peek-char))) 1) 56 | drain-input (current-input-port) 57 | say-name me 58 | say-words 59 | : ,answer 60 | 61 | 62 | define-syntax-rule : Duel fighter1 fighter2 63 | duel 64 | quote fighter1 65 | quote fighter2 66 | 67 | 68 | define : main args 69 | Duel 70 | Galtag Nimbleday 71 | Lowlife Pirate 72 | 73 | -------------------------------------------------------------------------------- /examples/evaluate-r7rs-benchmark.gnuplot: -------------------------------------------------------------------------------- 1 | # create data with r7rs-benchmark: cp ~/eigenes/Programme/r7rs-benchmarks/all.csv r7rs-benchmark-all.csv; for i in 1.8.8 2.0.14 2.2 2.9; do ./evaluate-r7rs-benchmark.w r7rs-benchmark-all.csv guile-$i --csv > /tmp/r7rs-bench-slowdown-guile-$i.csv; done; gnuplot -c evaluate-r7rs-benchmark.gnuplot 2 | set title "Slowdown vs. fastest, progression in Guile, using https://ecraven.github.io/r7rs-benchmarks/" 3 | set xtics rotate 45 4 | set log y 5 | set yrange [0.9:50] 6 | set ylabel "Slowdown vs. fastest / dimensionless" 7 | set xlabel "specific test" 8 | set terminal png size 1024,768 linewidth 2 9 | set output "evaluate-r7rs-benchmark.png" 10 | plot "/tmp/r7rs-bench-slowdown-guile-1.8.8.csv" u 0:($2):xtic(1) w linespoints title "1.8", "/tmp/r7rs-bench-slowdown-guile-2.0.14.csv" u 0:($2):xtic(1) w linespoints title "2.0", "/tmp/r7rs-bench-slowdown-guile-2.2.csv" u 0:($2):xtic(1) w linespoints title "2.2", "/tmp/r7rs-bench-slowdown-guile-2.9.csv" u 0:($2):xtic(1) w linespoints title "2.9" 11 | -------------------------------------------------------------------------------- /examples/evaluate-r7rs-benchmark.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/examples/evaluate-r7rs-benchmark.png -------------------------------------------------------------------------------- /examples/evaluate-r7rs-benchmark.scm: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L ~/wisp --language=wisp -s $0 "$@") 5 | (!#) 6 | 7 | ;; Evaluate the benchmarks from ecraven at http://ecraven.github.io/r7rs-benchmarks/benchmark.html 8 | ;; Uses data from http://ecraven.github.io/r7rs-benchmarks/all.csv 9 | 10 | ;; example usage: 11 | ;; $ for i in bigloo bones chez chibi chicken- chickencsi- cyclone femtolisp foment gambitc gauche guile ironscheme kawa larceny mit mosh petite picrin racket rhizome rscheme s9fes sagittarius scheme48- stalin tinyscheme vicare ypsilon; do echo $i $(./evaluate-r7rs-benchmark.w guile-ecraven-benchmarks-result-2017-08-13.csv $i | grep Geom -A 2 | grep -v = | grep .); done | sed 's/(//' > evaluate-r7rs-benchmark.data 12 | ;; $ echo -e 'set xtics rotate by 90 right\nplot "< sort -g -k2 evaluate-r7rs-benchmark.data" using 0:2:xtic(1) with lines title "runtime: geometric mean multiple of fastest", "< sort -g -k2 evaluate-r7rs-benchmark.data" using 0:3:xtic(1) with lines title "successful tests"' | gnuplot -p 13 | 14 | (import (ice-9 rdelim) 15 | (srfi srfi-1) 16 | (ice-9 pretty-print) 17 | (ice-9 optargs) 18 | (ice-9 i18n)) 19 | 20 | (define (read-csv port) 21 | (let loop ((lines '())) 22 | (if (eof-object? (peek-char port )) 23 | (reverse (map (λ (x) (string-split x #\,)) lines 24 | loop (cons (read-line port) lines 25 | 26 | define (min-alist-by-test data-by-project 27 | let lp 28 | (min-data '() 29 | data-by-project data-by-project 30 | if (null? data-by-project 31 | . min-data 32 | let* 33 | (proj (car (car data-by-project 34 | test (car (cdr (car data-by-project 35 | time (string->number (car (cdr (cdr (car data-by-project 36 | best (assoc-ref min-data test 37 | lp 38 | if (and time (or (not best) (< time best 39 | assoc-set! min-data test time 40 | . min-data 41 | cdr data-by-project 42 | 43 | define (select-project-data data-by-project project 44 | define (notproj? datapoint 45 | not (string-prefix? project (car datapoint 46 | define (only-project data 47 | remove notproj? data 48 | map cdr (only-project data-by-project 49 | 50 | define (get-multiples guile-data data-min-by-test 51 | let lp 52 | (gd guile-data 53 | multiples-of-best '() 54 | if (null? gd 55 | remove (λ(x) (equal? #f x)) multiples-of-best 56 | let* 57 | (guile (string->number (car (cdr (car gd 58 | test (car (car gd 59 | multiple 60 | if (not guile 61 | . guile 62 | / guile 63 | or (assoc-ref data-min-by-test test) guile 64 | lp (cdr gd 65 | if multiple 66 | cons multiple multiples-of-best 67 | . multiples-of-best 68 | 69 | 70 | define (help args 71 | format #t "Usage: ~a csv-file [project-prefix]\n" (car args) 72 | 73 | define args (program-arguments 74 | 75 | when (null? (cdr args 76 | help args 77 | exit 1 78 | 79 | define csv-file 80 | car (cdr args 81 | 82 | define project-prefix 83 | if (null? (cdr (cdr args 84 | . "guile" 85 | car (cdr (cdr args 86 | 87 | let* 88 | (port (open-input-file csv-file 89 | data-by-project (read-csv port 90 | data-min-by-test (min-alist-by-test data-by-project 91 | guile-data (select-project-data data-by-project project-prefix 92 | display "=== Best times ===\n\n" 93 | pretty-print (sort data-min-by-test (λ (x y) (stringnumber (car (cdr x))))) guile-data 109 | length guile-data 110 | newline 111 | ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 112 | 113 | -------------------------------------------------------------------------------- /examples/factorial.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples factorial) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | (define-module (examples factorial) 7 | #:export (factorial)) 8 | 9 | (define (factorial n ); (define (factorial n) 10 | (if (zero? n ); (if (zero? n) 11 | 1 ; => 1 12 | (* n (factorial {n - 1} )))); (* n (factorial {n - 1})))) 13 | 14 | (define (main args) 15 | (display (factorial 5)) 16 | (newline)) 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /examples/factorial.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples factorial)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples factorial 8 | . #:export : factorial main 9 | 10 | define : factorial n ; (define (factorial n) 11 | if : zero? n ; (if (zero? n) 12 | . 1 ; => 1 13 | * n : factorial {n - 1} ; (* n (factorial {n - 1})))) 14 | 15 | define : main args 16 | display : factorial 5 17 | newline 18 | 19 | -------------------------------------------------------------------------------- /examples/fib.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | ;; Fibonacci Functions 8 | 9 | (define (fibonacci n) 10 | "Get Fibonacci Element N in Linear Time" 11 | (let rek ((i 0) (u 1) (v 1)) 12 | (if (>= i (- n 2)) 13 | v 14 | (rek (+ i 1) v (+ u v) )))); else 15 | 16 | ; display : fib 5 17 | 18 | ;; Try it with curly infix 19 | 20 | ;; First activate curly infix 21 | #!curly-infix 22 | 23 | ;; Now define fibonacci with curly infix. 24 | (define (fibonacci n) 25 | "Get Fibonacci Element N in Linear Time" 26 | (let rek ((i 0) (u 1) (v 1)) 27 | (if {i >= {n - 2}} 28 | v 29 | (rek {i + 1} v {u + v})))) 30 | 31 | (display 32 | {1 + 1}) 33 | (newline) 34 | 35 | ;; And a complete infix-fibonacci 36 | (define (fibcurl2 n) 37 | "Get Fibonacci Elements in Linear Time" 38 | (let rek ((i 0) (u 1) (v 1)) 39 | (if { i >= { n - 2 } } 40 | v 41 | (rek { i + 1 } v { u + v })))) 42 | 43 | (display (fibcurl2 5)) 44 | (newline) 45 | 46 | 47 | -------------------------------------------------------------------------------- /examples/fib.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile-2.0 -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples fib)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples fib 8 | . #:export : main 9 | 10 | ;; Fibonacci Functions 11 | 12 | define : fibonacci n 13 | . "Get Fibonacci Element N in Linear Time" 14 | let rek : (i 0) (u 1) (v 1) 15 | if : >= i : - n 2 16 | . v 17 | rek (+ i 1) v (+ u v) ; else 18 | 19 | ; display : fib 5 20 | 21 | ;; Try it with curly infix 22 | 23 | ;; First activate curly infix 24 | . #!curly-infix 25 | 26 | ;; Now define fibonacci with curly infix. 27 | define : fibonacci n 28 | . "Get Fibonacci Element N in Linear Time" 29 | let rek : (i 0) (u 1) (v 1) 30 | if {i >= {n - 2}} 31 | . v 32 | rek {i + 1} v {u + v} 33 | 34 | display 35 | . {1 + 1} 36 | newline 37 | 38 | ;; And a complete infix-fibonacci 39 | define : fibcurl2 n 40 | . "Get Fibonacci Elements in Linear Time" 41 | let rek : (i 0) (u 1) (v 1) 42 | if { i >= { n - 2 } } 43 | . v 44 | rek { i + 1 } v { u + v } 45 | 46 | define : main args 47 | display : fibcurl2 5 48 | newline 49 | -------------------------------------------------------------------------------- /examples/files/test: -------------------------------------------------------------------------------- 1 | test -------------------------------------------------------------------------------- /examples/fizzbuzz.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (guildhall ext foof-loop))') 4 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 5 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 6 | ; !# 7 | 8 | ;; this example needs foof-loop installed via guildhall! 9 | (use-modules (guildhall ext foof-loop)) 10 | ;; Pseudocode adapted from 11 | ;; http://en.wikipedia.org/wiki/Pseudocode#Syntax 12 | (define (divisible? number divisor) 13 | (= 0 (remainder number divisor))) 14 | 15 | (define (fizzbuzz) 16 | (let 17 | ((print_number #f)) 18 | (loop 19 | ((for i (up-from 1 (to 100)))) 20 | (set! print_number #t) 21 | (when (divisible? i 3) 22 | (display "Fizz") 23 | (set! print_number #f)) 24 | (when (divisible? i 5) 25 | (display "Buzz") 26 | (set! print_number #f)) 27 | (when print_number (display i)) 28 | (newline)))) 29 | 30 | (fizzbuzz) 31 | 32 | 33 | -------------------------------------------------------------------------------- /examples/fizzbuzz.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (guildhall ext foof-loop))' 4 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 5 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples fizzbuzz)' -c '' "$@" 6 | ; !# 7 | 8 | define-module : examples fizzbuzz 9 | . #:export : main 10 | 11 | ;; this example needs foof-loop installed via guildhall! 12 | import : guildhall ext foof-loop 13 | ;; Pseudocode adapted from 14 | ;; http://en.wikipedia.org/wiki/Pseudocode#Syntax 15 | define : divisible? number divisor 16 | = 0 : remainder number divisor 17 | 18 | define : fizzbuzz 19 | let 20 | : print_number #f 21 | loop 22 | : for i : up-from 1 : to 100 23 | set! print_number #t 24 | when : divisible? i 3 25 | display "Fizz" 26 | set! print_number #f 27 | when : divisible? i 5 28 | display "Buzz" 29 | set! print_number #f; 30 | when print_number : display i 31 | newline 32 | 33 | define : main args 34 | fizzbuzz 35 | -------------------------------------------------------------------------------- /examples/gnuplot.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec) (language wisp))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples gnuplot)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples gnuplot 8 | . #:export : main plot-numbers 9 | 10 | import : ice-9 optargs 11 | ice-9 rdelim 12 | ice-9 popen 13 | 14 | define* : plot-numbers numbers #:key (output "/tmp/plot.png") (set-options '((term png))) (plot-options '()) (title #f) 15 | . "set options and plot options are converted via symbol->string and joined via string-join to pass them to gnuplot" 16 | let : : tmp : mkstemp! (string-append (tmpnam) "XXXXXX") "w+" 17 | map : λ (number) (display (exact->inexact number) tmp) (newline tmp) 18 | . numbers 19 | force-output tmp 20 | let : : port : open-output-pipe "gnuplot" 21 | map : λ(x) (format port "set ~a\n" (string-join (map symbol->string x))) 22 | . set-options 23 | when output 24 | format port "set output \"~a\"\n" output 25 | format port "plot \"~a\" ~a ~a\n" 26 | port-filename tmp 27 | if title 28 | format #f "title \"~a\"" title 29 | . "" 30 | string-join (map symbol->string plot-options) 31 | display output 32 | newline 33 | 34 | define : main args 35 | plot-numbers '(1 2 3 5.76) #:title "testdata" #:plot-options '(with lines) 36 | -------------------------------------------------------------------------------- /examples/guile-gi.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | # REQUIREMENTS: 4 | # - Guile-GI 5 | # - libffi 6 | # - GLib 7 | # - GObject-Introspection aka GIRepository 8 | # set Guile if unset 9 | if [ -z ${GUILE+x} ]; then 10 | GUILE=guile 11 | fi 12 | # temporary workaround to find libguile-gi 13 | export GUILE_SYSTEM_EXTENSIONS_PATH="$HOME/.guix-profile/lib/guile/3.0/" 14 | "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 15 | exec -a "$0" "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples guile-gi)' -c '' "$@" 16 | ; !# 17 | 18 | define-module : examples guile-gi 19 | . #:export : main 20 | 21 | import (gi) (gi repository) 22 | 23 | require "Gio" "2.0" 24 | require "Gtk" "3.0" 25 | 26 | load-by-name "Gio" "Application" ;; activate, run 27 | load-by-name "Gtk" "Application" 28 | load-by-name "Gtk" "ApplicationWindow" 29 | load-by-name "Gtk" "Button" 30 | load-by-name "Gtk" "ButtonBox" 31 | load-by-name "Gtk" "Widget" ;; show-all 32 | load-by-name "Gtk" "DrawingArea" 33 | 34 | define : print-hello widget 35 | display "Hello World\n" 36 | 37 | define : activate-callback app 38 | let* 39 | : window (make 40 | #:application app 41 | #:default-height 200 42 | #:default-width 200 43 | #:title "Window") 44 | button-box (make #:parent window) 45 | button (make 46 | #:parent button-box 47 | #:label "Hello world") 48 | ;; DrawingArea does not work yet: https://developer.gnome.org/gtk3/stable/GtkDrawingArea.html 49 | drawing-area (make 50 | #:parent window) 51 | widget:set-size-request drawing-area 100 100 52 | connect drawing-area draw : lambda _ (write 1) (newline) 53 | connect button clicked print-hello 54 | connect button clicked : lambda _ : destroy window 55 | show-all window 56 | 57 | define : main 58 | let : : app (make #:application-id "org.gtk.example") 59 | connect app activate activate-callback 60 | run app : command-line 61 | 62 | main 63 | -------------------------------------------------------------------------------- /examples/heapsort.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | # Just a fun example of a heapsort using a vector 4 | # set Guile if unset 5 | if [ -z ${GUILE+x} ]; then 6 | GUILE=guile 7 | fi 8 | echo ${GUILE} 9 | "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 10 | exec -a "$0" "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples heapsort)' -c '' "$@" 11 | ; !# 12 | 13 | define-module : examples heapsort 14 | . #:export : main 15 | 16 | import : only (srfi srfi-43) vector-swap! 17 | ice-9 pretty-print 18 | 19 | define : heapsort data 20 | define array : list->vector data 21 | define len : vector-length array 22 | ;; heaps use 1-indexed indizes for their simple next-index 23 | ;; calculation, so we use our own functions 24 | define : heap-set! i value 25 | vector-set! array { i - 1 } value 26 | define : heap-ref i 27 | vector-ref array { i - 1 } 28 | define : heap-swap! i j 29 | vector-swap! array { i - 1 } { j - 1 } 30 | 31 | define : left-child n 32 | * 2 n 33 | define : right-child n 34 | + 1 : left-child n 35 | define : parent n 36 | if {n = 1} 37 | . -1 38 | floor/ n 2 39 | define : bubble-down! p 40 | define min-index p 41 | define : update-min-index! child-index 42 | when { child-index < { len + 1 } } 43 | when : < (heap-ref child-index) (heap-ref min-index) 44 | set! min-index child-index 45 | update-min-index! : left-child p 46 | update-min-index! : right-child p 47 | when : not { min-index = p } 48 | heap-swap! p min-index 49 | bubble-down! min-index 50 | define : extract-min! 51 | define min -1 52 | when { len > 0 } 53 | set! min : heap-ref 1 54 | heap-set! 1 : heap-ref { len } 55 | heap-set! len #f 56 | set! len { len - 1 } 57 | bubble-down! 1 58 | . min 59 | let loop : : i : floor/ len 2 60 | when {i >= 1} 61 | bubble-down! i 62 | loop { i - 1 } 63 | map : λ _ : extract-min! 64 | . data 65 | 66 | define : main args 67 | define data : reverse! : iota 100000 68 | display : car : heapsort data 69 | newline 70 | -------------------------------------------------------------------------------- /examples/hello-world-server.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | (use-modules 8 | (web server)) 9 | 10 | ; first the plain text header 11 | (define (header) 12 | '((content-type . (text/plain)))) 13 | 14 | ; now content building functions 15 | (define (timestring) 16 | (string-join 17 | (list 18 | ; use gmtime instead of localtime if you want UTC 19 | (number->string (tm:hour (localtime (current-time)))) 20 | (number->string (tm:min (localtime (current-time))))) 21 | ":" )); delimiter 22 | 23 | (define (greeting) 24 | (if (string? (getlogin)) 25 | (getlogin) 26 | "Mellon?")) 27 | 28 | (define (content) 29 | (let ((text "Hello World!" )); the let is wisp syntax showoff… 30 | (string-join 31 | (list 32 | text 33 | (greeting) 34 | (timestring)) 35 | "\n" ))); delimiter 36 | 37 | ; and the request handler 38 | (define (hello-world-handler request request-body) 39 | (values 40 | (header) 41 | (content))) 42 | 43 | (display "Server starting. Test it at http://127.0.0.1:8084") 44 | (newline) 45 | 46 | (run-server hello-world-handler 'http '(#:port 8084)) 47 | 48 | 49 | -------------------------------------------------------------------------------- /examples/hello-world-server.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples hello-world-server)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples hello-world-server 8 | . #:export : main 9 | 10 | use-modules 11 | web server 12 | 13 | ; first the plain text header 14 | define : header 15 | ' : content-type . : text/plain 16 | 17 | ; now content building functions 18 | define : timestring 19 | string-join 20 | list 21 | ; use gmtime instead of localtime if you want UTC 22 | number->string : tm:hour : localtime : current-time 23 | number->string : tm:min : localtime : current-time 24 | . ":" ; delimiter 25 | 26 | define : greeting 27 | if : string? : getlogin 28 | getlogin 29 | . "Mellon?" 30 | 31 | define : content 32 | let : : text "Hello World!" ; the let is wisp syntax showoff… 33 | string-join 34 | list 35 | . text 36 | greeting 37 | timestring 38 | . "\n" ; delimiter 39 | 40 | ; and the request handler 41 | define : hello-world-handler request request-body 42 | values 43 | header 44 | content 45 | 46 | define : main args 47 | display "Server starting. Test it at http://127.0.0.1:8084" 48 | newline 49 | 50 | run-server hello-world-handler 'http ' : #:port 8084 51 | -------------------------------------------------------------------------------- /examples/hoist-in-loop.w: -------------------------------------------------------------------------------- 1 | ;; This is partial example code taken from the loop optimization Guile code at 2 | ;; http://git.savannah.gnu.org/gitweb/?p=guile.git;a=blob;f=module/language/cps/licm.scm;h=3b343a66bd8ed4a591a9e97edbf1179a4d3a78a8;hb=HEAD 3 | 4 | ; I chose this example because this code felt very dense when I first 5 | ; read it, so I wanted to check whether this improves with wisp 6 | ; syntax. 7 | 8 | ; but first the copyright information from the header of the file: 9 | 10 | ;;; Continuation-passing style (CPS) intermediate language (IL) 11 | 12 | ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. 13 | 14 | ;;;; This library is free software; you can redistribute it and/or 15 | ;;;; modify it under the terms of the GNU Lesser General Public 16 | ;;;; License as published by the Free Software Foundation; either 17 | ;;;; version 3 of the License, or (at your option) any later version. 18 | ;;;; 19 | ;;;; This library is distributed in the hope that it will be useful, 20 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 22 | ;;;; Lesser General Public License for more details. 23 | ;;;; 24 | ;;;; You should have received a copy of the GNU Lesser General Public 25 | ;;;; License along with this library; if not, write to the Free Software 26 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 27 | 28 | define : hoist-in-loop cps entry body-labels succs preds effects 29 | let* 30 | : 31 | interior-succs 32 | intmap-map 33 | lambda : label succs 34 | intset-intersect succs body-labels 35 | . succs 36 | sorted-labels : compute-reverse-post-order interior-succs entry 37 | header-label : fresh-label 38 | header-cont : intmap-ref cps entry 39 | loop-vars 40 | match header-cont 41 | : $ $kargs names vars 42 | list->intset vars 43 | loop-effects 44 | persistent-intmap 45 | intset-fold 46 | lambda : label loop-effects 47 | let 48 | : 49 | label* 50 | if : eqv? label entry 51 | . header-label 52 | . label 53 | fx : intmap-ref effects label 54 | intmap-add! loop-effects label* fx 55 | body-labels empty-intmap 56 | pre-header-label entry 57 | pre-header-cont 58 | match header-cont 59 | : $ $kargs names vars term 60 | let : : vars* : map (lambda (_) (fresh-var)) vars 61 | build-cont 62 | $kargs names vars* 63 | $continue header-label #f 64 | $values vars* 65 | cps : intmap-add! cps header-label header-cont 66 | cps : intmap-replace! cps pre-header-label pre-header-cont 67 | to-visit 68 | match sorted-labels 69 | : head . tail 70 | unless : eqv? head entry 71 | error "what?" 72 | cons header-label tail 73 | define : rename-back-edges cont 74 | define : rename label 75 | if : eqv? label entry 76 | . header-label 77 | . label 78 | rewrite-cont cont 79 | : $ $kargs names vars : $ $continue kf src : $ $branch kt exp 80 | $kargs names vars 81 | $continue (rename kf) src : $branch (rename kt) ,exp 82 | : $ $kargs names vars : $ $continue k src exp 83 | $kargs names vars 84 | $continue (rename k) src ,exp 85 | : $ $kreceive ($ $arity req () rest) k 86 | $kreceive req rest (rename k) 87 | let lp 88 | : cps cps 89 | to-visit to-visit 90 | loop-vars loop-vars 91 | loop-effects loop-effects 92 | pre-header-label pre-header-label 93 | always-reached? #t 94 | match to-visit 95 | () cps 96 | : label . to-visit 97 | call-with-values 98 | lambda : 99 | hoist-one cps label (intmap-ref cps label) preds 100 | . loop-vars loop-effects 101 | . pre-header-label always-reached? 102 | lambda : cps cont loop-vars loop-effects pre-header-label always-reached? 103 | lp : intmap-replace! cps label : rename-back-edges cont 104 | . to-visit 105 | . loop-vars loop-effects pre-header-label always-reached? 106 | -------------------------------------------------------------------------------- /examples/ild.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (D="$(dirname $(realpath "$0"))" 4 | W="$(dirname $(dirname $(realpath "$0")))" 5 | guile -L "$W" -c '(import (wisp-scheme) (language wisp spec))') 6 | (exec guile -L "$W" --language=wisp -l "$D/enter-three-witches.w" -s "$0" "$@") 7 | ; !# 8 | 9 | (import (examples enter-three-witches)) 10 | 11 | (Enter (Dr. Arne Bab.)) 12 | 13 | (Dr. Arne Bab. 14 | (Hallo Liebste,) 15 | (,(color 'red) Ich ,(color 'yellow) liebe ,(color 'red) Dich ,(color #f)) 16 | (Dein Arne)) 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/ild.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | D="$(dirname $(realpath "$0"))" 4 | W="$(dirname $(dirname $(realpath "$0")))" 5 | guile -L "$W" -c '(import (wisp-scheme) (language wisp spec))' 6 | exec -a "$0" guile -L "$W" --language=wisp -x .w -e '(examples ild)' -c '' "$@" 7 | ; !# 8 | 9 | define-module : examples ild 10 | . #:export : main 11 | 12 | import : examples enter-three-witches 13 | 14 | define : main args 15 | Enter : Dr. Arne Bab. 16 | 17 | Dr. Arne Bab. 18 | Hallo Liebste, 19 | ,(color 'red) Ich ,(color 'yellow) liebe ,(color 'red) Dich ,(color #f) 20 | Dein Arne 21 | -------------------------------------------------------------------------------- /examples/lisp2wisp.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples lisp2wisp)' -c '' "$@" 5 | ; !# 6 | 7 | ;; Turning lisp-code programs into wisp-code — approximate inverse of wisp2lisp. 8 | 9 | ;; Limitation: Currently this strips out comments. TODO: strip all comments and assign them to the correct lines categorized by line-number. 10 | 11 | ;; Approach: 12 | ;; - Read the AST as list of lists with repeated (read) 13 | ;; - Turn it into basic wisp that only uses the : for empty lines and uses no parens at all 14 | ;; - Collapse lines using : and () with a heuristic (maximum line-length, known forms). 15 | ;; - use curly-infix 16 | 17 | ;; for emacs (progn (defun test-this-file () (interactive) (save-current-buffer) (async-shell-command (concat (buffer-file-name (current-buffer)) " --test"))) (local-set-key (kbd "") 'test-this-file)) 18 | 19 | 20 | 21 | define-module : examples lisp2wisp 22 | . #:export (lisp2wisp main) 23 | 24 | import : examples doctests 25 | srfi srfi-1 ; list operations 26 | srfi srfi-37 ; commandline parsing 27 | srfi srfi-9 ; records 28 | only (srfi srfi-26) cut 29 | rnrs bytevectors 30 | ice-9 optargs 31 | ice-9 match 32 | ice-9 format 33 | ice-9 rdelim ; for read-string 34 | ice-9 binary-ports 35 | ice-9 pretty-print 36 | 37 | define : read-file filepath 38 | let* 39 | : port : open-input-file filepath 40 | data : read-delimited "" port 41 | close port 42 | . data 43 | 44 | define : write-file filepath bytevector 45 | let* 46 | : port : open-output-file filepath 47 | put-bytevector port bytevector 48 | close port 49 | 50 | 51 | define : read-all port 52 | let loop : : res : ' 53 | let : : next : read port 54 | if : eof-object? next 55 | . res 56 | loop : append res : list next 57 | 58 | define : format-basic-wisp code 59 | let loop : (depth 0) (code code) 60 | cond 61 | : list? code 62 | string-append 63 | loop depth : car code 64 | if (null? (cdr code)) "" " " 65 | string-join : map (cut loop (+ depth 1) <>) : cdr code 66 | if (pair? (car code)) "\n" " " 67 | else 68 | pretty-print code 69 | format #f "~s" code 70 | 71 | define : format-wisp-lines code 72 | string-join 73 | map format-basic-wisp code 74 | . "\n" 75 | 76 | define : lisp2wisp port 77 | ## 78 | tests 79 | test-equal : string-trim-right : read-file "../tests/btest.w" 80 | lisp2wisp : open-input-file "../tests/btest.scm" 81 | test-equal : string-trim-right : read-file "../tests/dotted-pair.w" 82 | lisp2wisp : open-input-file "../tests/dotted-pair.scm" 83 | format-wisp-lines : read-all port 84 | 85 | define %this-module : current-module 86 | define : main args 87 | doctests-testmod %this-module 88 | -------------------------------------------------------------------------------- /examples/macros.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | ;; Testing syntax-rules and syntax-case with wisp 8 | 9 | ;; Syntax-case: add1 (from guile docs) 10 | (define-syntax add1 11 | (lambda (x) 12 | (syntax-case x () 13 | ((_ exp) 14 | (syntax (+ exp 1)))))) 15 | 16 | ;; use the #' shorthand for syntax 17 | (define-syntax add2 18 | (lambda (x) 19 | (syntax-case x () 20 | ((_ exp) 21 | #'(+ exp 2))))) 22 | 23 | ;; Syntax-rules add which requires at least 1 argument 24 | (define-syntax add-with-argument 25 | (syntax-rules () 26 | ((_ a b ...) 27 | (+ a b ...)))) 28 | 29 | ;; Same with syntax-case 30 | (define-syntax add-with-argument 31 | (lambda (x) 32 | (syntax-case x () 33 | ((_ a b ...) 34 | #'(+ a b ...))))) 35 | 36 | ; format #t "this breaks\n" 37 | ; add-with-argument 38 | (format #t "returns 1: ~A\n" (add-with-argument 1)) 39 | 40 | 41 | -------------------------------------------------------------------------------- /examples/macros.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples macros)' -c '' "$@" 5 | ; !# 6 | 7 | ;; Testing syntax-rules and syntax-case with wisp 8 | 9 | define-module : examples macros 10 | . #:export : main 11 | 12 | ;; Syntax-case: add1 (from guile docs) 13 | define-syntax add1 14 | lambda : x 15 | syntax-case x : 16 | : _ exp 17 | syntax : + exp 1 18 | 19 | ;; use the #' shorthand for syntax 20 | define-syntax add2 21 | lambda : x 22 | syntax-case x : 23 | : _ exp 24 | #' + exp 2 25 | 26 | ;; Syntax-rules add which requires at least 1 argument 27 | define-syntax add-with-argument 28 | syntax-rules : 29 | : _ a b ... 30 | + a b ... 31 | 32 | ;; Same with syntax-case 33 | define-syntax add-with-argument 34 | lambda : x 35 | syntax-case x : 36 | : _ a b ... 37 | #' + a b ... 38 | 39 | define : main args 40 | ; format #t "this breaks\n" 41 | ; add-with-argument 42 | format #t "returns 1: ~A\n" : add-with-argument 1 43 | -------------------------------------------------------------------------------- /examples/map-product-sums.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples map-product-sums) main)' -s "$0" "$@") 3 | ; !# 4 | 5 | (define-module (examples map-product-sums)) 6 | 7 | (use-modules (srfi srfi-42)) 8 | 9 | (define (list-product-sums list-of-numbers) 10 | "return a list with the sum of the products of each number with all other numbers. 11 | 12 | >>> map-product-sums '(2 4 6) 13 | (list (+ (* 2 4) (* 2 6)) (+ (* 4 2) (* 4 6)) (+ (* 6 2) (* 6 4))) 14 | " 15 | (map (lambda (x) (apply + x)) 16 | (list-ec (: i list-of-numbers) 17 | (map (lambda (x) (* i x)) 18 | (cons (- i) list-of-numbers))))) 19 | 20 | 21 | (define (main . args) 22 | (write (list-product-sums '(2 4 6)))) 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /examples/map-product-sums.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples map-product-sums)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples map-product-sums 8 | . #:export : main 9 | 10 | use-modules : srfi srfi-42 11 | 12 | define : list-product-sums list-of-numbers 13 | . "return a list with the sum of the products of each number with all other numbers. 14 | 15 | >>> map-product-sums '(2 4 6) 16 | (list (+ (* 2 4) (* 2 6)) (+ (* 4 2) (* 4 6)) (+ (* 6 2) (* 6 4))) 17 | " 18 | map (lambda (x) (apply + x)) 19 | list-ec (: i list-of-numbers) 20 | map (lambda (x) (* i x)) 21 | cons (- i) list-of-numbers 22 | 23 | 24 | define : main . args 25 | write : list-product-sums '(2 4 6) 26 | 27 | -------------------------------------------------------------------------------- /examples/mercurial.scm: -------------------------------------------------------------------------------- 1 | ;;; GNU Guix --- Functional package management for GNU 2 | ;;; Copyright © 2013 Nikita Karetnikov 3 | ;;; Copyright © 2013 Cyril Roelandt 4 | ;;; Copyright © 2013 Ludovic Courtès 5 | ;;; 6 | ;;; This file is part of GNU Guix. 7 | ;;; 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it 9 | ;;; under the terms of the GNU General Public License as published by 10 | ;;; the Free Software Foundation; either version 3 of the License, or (at 11 | ;;; your option) any later version. 12 | ;;; 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but 14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;;; GNU General Public License for more details. 17 | ;;; 18 | ;;; You should have received a copy of the GNU General Public License 19 | ;;; along with GNU Guix. If not, see . 20 | 21 | (define-module (mercurial) 22 | #:use-module ((guix licenses) #:select (asl2.0 gpl1+ gpl2+ gpl3+)) 23 | #:use-module (guix packages) 24 | #:use-module (guix download) 25 | #:use-module (guix build-system gnu) 26 | #:use-module (guix build-system python) 27 | #:use-module (guix build utils) 28 | #:use-module (gnu packages libapr) 29 | #:use-module (gnu packages python) 30 | #:use-module (gnu packages system) 31 | #:use-module (gnu packages emacs) 32 | #:use-module (gnu packages compression)) 33 | 34 | (define-public hg 35 | (package 36 | (name "mercurial") 37 | (version "2.7.1") 38 | (source 39 | (origin 40 | (method url-fetch) 41 | (uri 42 | (string-append "http://mercurial.selenic.com/release/mercurial-" 43 | version ".tar.gz")) 44 | (sha256 45 | (base32 46 | "121m8f7vmipmdg00cnzdz2rjkgydh28mwfirqkrbs5fv089vywl4")))) 47 | (build-system python-build-system) 48 | (home-page "http://mercurial.selenic.com") 49 | (synopsis "Decentralized version control system") 50 | (description 51 | "Mercurial is a free, distributed source control management tool. 52 | It efficiently handles projects of any size 53 | and offers an easy and intuitive interface.") 54 | (license gpl2+))) 55 | 56 | 57 | -------------------------------------------------------------------------------- /examples/mercurial.w: -------------------------------------------------------------------------------- 1 | ;;; GNU Guix --- Functional package management for GNU 2 | ;;; Copyright © 2013 Nikita Karetnikov 3 | ;;; Copyright © 2013 Cyril Roelandt 4 | ;;; Copyright © 2013 Ludovic Courtès 5 | ;;; 6 | ;;; This file is part of GNU Guix. 7 | ;;; 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it 9 | ;;; under the terms of the GNU General Public License as published by 10 | ;;; the Free Software Foundation; either version 3 of the License, or (at 11 | ;;; your option) any later version. 12 | ;;; 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but 14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;;; GNU General Public License for more details. 17 | ;;; 18 | ;;; You should have received a copy of the GNU General Public License 19 | ;;; along with GNU Guix. If not, see . 20 | 21 | define-module : mercurial 22 | . #:use-module : (guix licenses) #:select : asl2.0 gpl1+ gpl2+ gpl3+ 23 | . #:use-module : guix packages 24 | . #:use-module : guix download 25 | . #:use-module : guix build-system gnu 26 | . #:use-module : guix build-system python 27 | . #:use-module : guix build utils 28 | . #:use-module : gnu packages libapr 29 | . #:use-module : gnu packages python 30 | . #:use-module : gnu packages system 31 | . #:use-module : gnu packages emacs 32 | . #:use-module : gnu packages compression 33 | 34 | define-public hg 35 | package 36 | name "mercurial" 37 | version "2.7.1" 38 | source 39 | origin 40 | method url-fetch 41 | uri 42 | string-append "http://mercurial.selenic.com/release/mercurial-" 43 | . version ".tar.gz" 44 | sha256 45 | base32 46 | . "121m8f7vmipmdg00cnzdz2rjkgydh28mwfirqkrbs5fv089vywl4" 47 | build-system python-build-system 48 | home-page "http://mercurial.selenic.com" 49 | synopsis "Decentralized version control system" 50 | description 51 | . "Mercurial is a free, distributed source control management tool. 52 | It efficiently handles projects of any size 53 | and offers an easy and intuitive interface." 54 | license gpl2+ 55 | -------------------------------------------------------------------------------- /examples/multithreaded-magic.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples multithreaded-magic) main)' -s "$0" "$@") 3 | ; !# 4 | 5 | (define-module (examples multithreaded-magic)) 6 | 7 | ; Mathematical magic: Always get one. 8 | ; 9 | ; Via http://www.liv.ac.uk/HPC/HTMLF90Course/HTMLF90CourseQuestionsnode18.html 10 | ; (actually for learning fortran) 11 | ; 12 | ; this is the wisp scheme version which I want to compare with the fortran version. 13 | 14 | ; Call as PATH=~/guile/meta:$PATH ./examples/multithreaded-magic.w 15 | 16 | (use-modules 17 | (ice-9 format) 18 | (ice-9 futures) 19 | (ice-9 threads)) 20 | 21 | (define (magic-threaded mutex futures integer) 22 | ; this can cause unordered output. It’s fun anyway : 23 | (let 24 | ( 25 | (futures 26 | (cons (future (with-mutex mutex (format #t "~30r\n" integer))) 27 | futures))) 28 | (if (not (= integer 1)) 29 | (if (even? integer) 30 | (magic-threaded mutex futures {integer / 2}) 31 | (magic-threaded mutex futures 32 | (truncate (+ 1 {integer / 3})))) 33 | (for-each touch futures)))) 34 | 35 | (define (magic integer) 36 | (magic-threaded 37 | (make-mutex) 38 | (list) 39 | integer)) 40 | 41 | (define (magic-simple integer) 42 | (format #t "~30r\n" integer) 43 | (if (not (= integer 1)) 44 | (if (even? integer) 45 | (magic-simple (/ integer 2)) 46 | (magic-simple (truncate (+ 1 (/ integer 3 ))))))) 47 | 48 | (define (main args) 49 | (display ";;; multithreaded magic ;;;\n") 50 | (magic 456189456156456196152615) 51 | (display ";;; simple magic ;;;\n") 52 | (magic-simple 456189456156456196152615)) 53 | 54 | 55 | -------------------------------------------------------------------------------- /examples/multithreaded-magic.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples multithreaded-magic)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples multithreaded-magic 8 | . #:export : main 9 | 10 | ; Mathematical magic: Always get one. 11 | ; 12 | ; Via http://www.liv.ac.uk/HPC/HTMLF90Course/HTMLF90CourseQuestionsnode18.html 13 | ; (actually for learning fortran) 14 | ; 15 | ; this is the wisp scheme version which I want to compare with the fortran version. 16 | 17 | ; Call as PATH=~/guile/meta:$PATH ./examples/multithreaded-magic.w 18 | 19 | use-modules 20 | ice-9 format 21 | ice-9 futures 22 | ice-9 threads 23 | 24 | define : magic-threaded mutex futures integer 25 | ; this can cause unordered output. It’s fun anyway : 26 | let 27 | : 28 | futures 29 | cons : future : with-mutex mutex : format #t "~30r\n" integer 30 | . futures 31 | if : not : = integer 1 32 | if : even? integer 33 | magic-threaded mutex futures {integer / 2} 34 | magic-threaded mutex futures 35 | truncate : + 1 {integer / 3} 36 | for-each touch futures 37 | 38 | define : magic integer 39 | magic-threaded 40 | make-mutex 41 | list 42 | . integer 43 | 44 | define : magic-simple integer 45 | format #t "~30r\n" integer 46 | if : not : = integer 1 47 | if : even? integer 48 | magic-simple : / integer 2 49 | magic-simple : truncate : + 1 : / integer 3 50 | 51 | define : main args 52 | display ";;; multithreaded magic ;;;\n" 53 | magic 456189456156456196152615 54 | display ";;; simple magic ;;;\n" 55 | magic-simple 456189456156456196152615 56 | -------------------------------------------------------------------------------- /examples/pipe.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # -*- scheme -*- 3 | exec guile -L $(dirname $(dirname $(realpath "$0"))) -e '(@@ (examples pipe) main)' -s "$0" "$@" 4 | ; !# 5 | 6 | ;; FIXME: Sometimes this stops early. 7 | ;; it should always be equivalent to echo 1 | echo 2 | echo 3 | echo 4 8 | ;; but sometimes it only does echo 1 | echo 2 9 | 10 | ;; Use pipes to connect several commands 11 | 12 | (define-module (examples pipe) 13 | #:export (!)) 14 | 15 | (import (ice-9 popen) 16 | (ice-9 rdelim) 17 | (only (srfi srfi-1) fold) 18 | (ice-9 pretty-print)) 19 | 20 | (define (! . cmds) 21 | "A pipe-procedure: connect each of the CMDS with the next 22 | in the list, the first with stdin and the last with stdout." 23 | (define (read-till-eof in-port) 24 | (read-delimited "" in-port)) 25 | (define (connect B A) 26 | (let 27 | ((in-port (if (port? A) A (open-input-pipe A))) 28 | (out-port (open-input-output-pipe B))) 29 | (pretty-print (cons A B)) 30 | (let ((data (read-till-eof in-port))) 31 | (pretty-print data) 32 | (display data out-port)) 33 | (close in-port) 34 | out-port)) 35 | (fold connect (car cmds) (cdr cmds))) 36 | 37 | (define (main args) 38 | (display (read-delimited "" (! "echo 1" "echo 2" "echo 3" "echo 4")))) 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /examples/pipe.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples pipe)' -c '' "$@" 5 | ; !# 6 | 7 | ;; FIXME: Sometimes this stops early. 8 | ;; it should always be equivalent to echo 1 | echo 2 | echo 3 | echo 4 9 | ;; but sometimes it only does echo 1 | echo 2 10 | 11 | ;; Use pipes to connect several commands 12 | 13 | define-module : examples pipe 14 | . #:export : ! main 15 | 16 | import : ice-9 popen 17 | ice-9 rdelim 18 | only (srfi srfi-1) fold 19 | ice-9 pretty-print 20 | 21 | define : ! . cmds 22 | . "A pipe-procedure: connect each of the CMDS with the next 23 | in the list, the first with stdin and the last with stdout." 24 | define : read-till-eof in-port 25 | read-delimited "" in-port 26 | define : connect B A 27 | let 28 | : in-port : if (port? A) A : open-input-pipe A 29 | out-port : open-input-output-pipe B 30 | pretty-print : cons A B 31 | let : (data (read-till-eof in-port)) 32 | pretty-print data 33 | display data out-port 34 | close in-port 35 | . out-port 36 | fold connect (car cmds) (cdr cmds) 37 | 38 | define : main args 39 | display : read-delimited "" : ! "echo 1" "echo 2" "echo 3" "echo 4" 40 | 41 | -------------------------------------------------------------------------------- /examples/power-iteration.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples power-iteration) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | ;; Power iteration, following https://en.wikipedia.org/wiki/Power_iteration#The_method 7 | 8 | (define-module (examples power-iteration) 9 | #:export (step)) 10 | 11 | (import (srfi srfi-1)) 12 | 13 | (define A '((1 2 3) (1 2 3) (1 2 4))) 14 | (define b '(1 1 1)) 15 | 16 | 17 | (define (M*v A b) 18 | "Matrix by vector product" 19 | (if (= 0 (length A)) 20 | '() 21 | (let lp ((res '()) (head 0) (i 0) (j 0)) 22 | (cond 23 | ({i >= (length A)} 24 | (reverse res)) 25 | ({j >= (length (list-ref A 0))} 26 | (lp (cons head res) 0 (+ 1 i) 0)) 27 | (else 28 | (lp res 29 | (+ head 30 | (* (list-ref (list-ref A i) j) 31 | (list-ref b j))) 32 | i 33 | (+ 1 j))))))) 34 | 35 | 36 | (define (normalize-squared v) 37 | (let lp ((norm 0) (idx 0)) 38 | (if {idx >= (length v)} 39 | (let loop ((res '()) (i 0)) 40 | (if {i >= (length v)} 41 | res 42 | (loop 43 | (cons (/ (list-ref v i) (sqrt norm)) 44 | res) 45 | (+ 1 i)))) 46 | (lp 47 | (+ norm (* (list-ref v idx) (list-ref v idx))) 48 | (+ idx 1))))) 49 | 50 | 51 | (define (î-step elem prev) 52 | (normalize-squared (M*v A prev))) 53 | 54 | (define (main args) 55 | (let lp ((i 0)) 56 | (write (fold î-step b (iota i))) 57 | (newline) 58 | (when {i < 10} 59 | (lp {i + 1}))) 60 | 61 | (write (normalize-squared (M*v A b))) 62 | (newline)) 63 | 64 | 65 | -------------------------------------------------------------------------------- /examples/power-iteration.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples power-iteration)' -c '' "$@" 4 | ; !# 5 | 6 | ;; Power iteration, following https://en.wikipedia.org/wiki/Power_iteration#The_method 7 | 8 | define-module : examples power-iteration 9 | . #:export : step main 10 | 11 | import : srfi srfi-1 12 | 13 | define A '((1 2 3) (1 2 3) (1 2 4)) 14 | define b '(1 1 1) 15 | 16 | 17 | define : M*v A b 18 | . "Matrix by vector product" 19 | if : = 0 : length A 20 | . '() 21 | let lp : (res '()) (head 0) (i 0) (j 0) 22 | cond 23 | {i >= (length A)} 24 | reverse res 25 | {j >= (length (list-ref A 0))} 26 | lp (cons head res) 0 (+ 1 i) 0 27 | else 28 | lp res 29 | + head 30 | * : list-ref (list-ref A i) j 31 | list-ref b j 32 | . i 33 | + 1 j 34 | 35 | 36 | define : normalize-squared v 37 | let lp : (norm 0) (idx 0) 38 | if {idx >= (length v)} 39 | let loop : (res '()) (i 0) 40 | if {i >= (length v)} 41 | . res 42 | loop 43 | cons : / (list-ref v i) : sqrt norm 44 | . res 45 | + 1 i 46 | lp 47 | + norm : * (list-ref v idx) (list-ref v idx) 48 | + idx 1 49 | 50 | 51 | define : î-step elem prev 52 | normalize-squared : M*v A prev 53 | 54 | define : main args 55 | let lp : (i 0) 56 | write : fold î-step b : iota i 57 | newline 58 | when {i < 10} 59 | lp {i + 1} 60 | 61 | write : normalize-squared : M*v A b 62 | newline 63 | -------------------------------------------------------------------------------- /examples/property.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples property) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | (define-module (examples property) 7 | #:export (main)) 8 | 9 | ; FIXME: this does not work when called from guile, but it works when 10 | ; first translating it to scheme and then calling the scheme file. 11 | 12 | ; The following works: 13 | 14 | ; guile ../wisp.scm property.w > property.scm; guile -e '(@@ (examples property) main)' -s property.scm 15 | 16 | (define y 5) 17 | (define-syntax z 18 | (identifier-syntax (var y) 19 | ((set! var val) 20 | (set! y (+ 1 val))))) 21 | 22 | (define (main args) 23 | (write args) 24 | (newline) 25 | (write z) 26 | (newline) 27 | (set! z 5) 28 | (write z) 29 | (newline)) 30 | 31 | 32 | -------------------------------------------------------------------------------- /examples/property.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples property)' -c '' "$@" 4 | ; !# 5 | 6 | define-module : examples property 7 | . #:export : main 8 | 9 | ; FIXME: this does not work when parsed as script from guile (with the -s switch), 10 | ; but it works when calling it as module as shown above. 11 | 12 | define y 5 13 | define-syntax z 14 | identifier-syntax : var y 15 | : set! var val 16 | set! y : + 1 val 17 | 18 | define : main args 19 | write args 20 | newline 21 | write z 22 | newline 23 | set! z 5 24 | write z 25 | newline 26 | -------------------------------------------------------------------------------- /examples/ptifrrabirrf.w: -------------------------------------------------------------------------------- 1 | ;; the name is an in-joke 2 | import 3 | only (fake import) file-or-http-url? 4 | . resource-reference string-replace-substring 5 | 6 | define : ptifrrabirrf path unresolved 7 | define : convert s 8 | string-replace-substring s "%20" " " 9 | when : or (not path) (not unresolved) 10 | error "Illegal Argument: path and unresolved must not be #false, 11 | but path was ~a and unresolved was ~a" 12 | . path unresolved 13 | 14 | if : or (file-or-http-url? path) (file-exists? path) 15 | resource-reference path unresolved 16 | let : : converted-path : convert path 17 | if : file-exists? converted-path 18 | resource-reference converted-path : convert unresolved 19 | resource-reference path unresolved 20 | -------------------------------------------------------------------------------- /examples/running_mean_std.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | (use-modules (srfi srfi-11)) 8 | 9 | (define (running-stat-fun) 10 | (let 11 | ((n 0) 12 | (sum 0) 13 | (sum² 0)) 14 | (define (mean-std x) 15 | (set! n (+ n 1)) 16 | (set! sum (+ sum x)) 17 | (set! sum² (+ sum² (expt x 2))) 18 | (let* 19 | ((mean (/ sum n)) 20 | (σ 21 | (- (/ sum² n) 22 | mean))) 23 | (values mean σ))) 24 | mean-std)) 25 | 26 | (define statfun (running-stat-fun)) 27 | 28 | (write (statfun 5)) 29 | (newline) 30 | (write (statfun 4)) 31 | (newline) 32 | (let-values 33 | (((mean σ) (statfun 5))) 34 | (display mean ) 35 | (display '±) 36 | (display σ) 37 | (newline)) 38 | 39 | 40 | -------------------------------------------------------------------------------- /examples/running_mean_std.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples running_mean_std)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples running_mean_std 8 | . #:export : main 9 | 10 | use-modules : srfi srfi-11 11 | 12 | define : running-stat-fun 13 | let 14 | : n 0 15 | sum 0 16 | sum² 0 17 | define : mean-std x 18 | set! n : + n 1 19 | set! sum : + sum x 20 | set! sum² : + sum² : expt x 2 21 | let* 22 | : mean : / sum n 23 | σ 24 | - : / sum² n 25 | . mean 26 | values mean σ 27 | . mean-std 28 | 29 | define statfun : running-stat-fun 30 | 31 | define : main args 32 | write : statfun 5 33 | newline 34 | write : statfun 4 35 | newline 36 | let-values 37 | : (mean σ) : statfun 5 38 | display mean 39 | display '± 40 | display σ 41 | newline 42 | 43 | -------------------------------------------------------------------------------- /examples/say.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples say) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | ; Simple specialized syntax for writing natural text with scheme. 7 | 8 | (define-module (examples say) 9 | #:export (main)) 10 | 11 | ; TODO: rewrite for syntax-case with recursion into sub-lists. 12 | ; Goal: say Yes, this works ,(red 1 2) . 13 | 14 | ; TODO: longterm goal: simply syntax for writing plays. The header 15 | ; with active persons defines macros which are like say, but 16 | ; personalized. The code should read like the output of 17 | ; classical JRPGs. 18 | 19 | (define-syntax-rule (say a ...) 20 | (format #t "~A\n" 21 | (string-join 22 | (map symbol->string (quote (a ...)))))) 23 | 24 | (define (main argv) 25 | (say Yes, this works!)) 26 | 27 | 28 | -------------------------------------------------------------------------------- /examples/say.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples say)' -c '' "$@" 4 | ; !# 5 | 6 | ; Simple specialized syntax for writing natural text with scheme. 7 | 8 | define-module : examples say 9 | . #:export : main 10 | 11 | ; TODO: rewrite for syntax-case with recursion into sub-lists. 12 | ; Goal: say Yes, this works ,(red 1 2) . 13 | 14 | ; TODO: longterm goal: simply syntax for writing plays. The header 15 | ; with active persons defines macros which are like say, but 16 | ; personalized. The code should read like the output of 17 | ; classical JRPGs. 18 | 19 | define-syntax-rule : say a ... 20 | format #t "~A\n" 21 | string-join 22 | map symbol->string : quote : a ... 23 | 24 | define : main argv 25 | say Yes, this works! 26 | -------------------------------------------------------------------------------- /examples/sh.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples sh) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | ;; simplest way to run shell commands 7 | 8 | (define-module (examples sh) 9 | #:export (sh)) 10 | 11 | (use-modules (srfi srfi-1)) 12 | 13 | (define (->string thing) 14 | (if (symbol? thing) 15 | (symbol->string thing) 16 | (format #f "\"~A\"" thing))) 17 | 18 | (define (run-me . args) 19 | (system (string-join (map ->string args)))) 20 | 21 | (define-syntax-rule (sh args ...) 22 | (apply run-me (quote (args ...)))) 23 | 24 | (define (main args) 25 | (sh echo foo | sed s/o/u/)) 26 | 27 | 28 | -------------------------------------------------------------------------------- /examples/sh.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples sh)' -c '' "$@" 4 | ; !# 5 | 6 | ;; simplest way to run shell commands 7 | 8 | define-module : examples sh 9 | . #:export : sh main 10 | 11 | use-modules : srfi srfi-1 12 | 13 | define : ->string thing 14 | if : symbol? thing 15 | symbol->string thing 16 | format #f "\"~A\"" thing 17 | 18 | define : run-me . args 19 | system : string-join : map ->string args 20 | 21 | define-syntax-rule : sh args ... 22 | apply run-me : quote : args ... 23 | 24 | define : main args 25 | sh echo foo | sed s/o/u/ 26 | -------------------------------------------------------------------------------- /examples/string-replace-benchmark.scm: -------------------------------------------------------------------------------- 1 | (define-module (examples string-replace-benchmark) 2 | #:export (string-replace-substring string-replace-substring/startindex string-replace-substring/addindex string-replace-substring/naive)) 3 | 4 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 5 | ; 0.010369s real time, 0.010348s run time. 0.000000s spent in GC. 6 | (define* 7 | (string-replace-substring s substr replacement 8 | #:optional (start 0) (end (string-length s))) 9 | "Replace every instance of substring in s by replacement." 10 | (let ((substr-length (string-length substr))) 11 | (if (zero? substr-length) 12 | (error "string-replace-substring: empty substr") 13 | (let loop 14 | ((start start) 15 | (pieces (list (substring s 0 start)))) 16 | (let ((idx (string-contains s substr start end))) 17 | (if idx 18 | (loop (+ idx substr-length) 19 | (cons* replacement 20 | (substring s start idx) 21 | pieces)) 22 | (string-concatenate-reverse 23 | (cons (substring s start) 24 | pieces)))))))) 25 | 26 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 27 | ; 1.112429s real time, 1.083435s run time. 0.780863s spent in GC. 28 | (define (string-replace-substring/startindex s substring replacement) 29 | "Replace every instance of substring in s by replacement." 30 | (let ((sublen (string-length substring))) 31 | (let replacer 32 | ((newstring s) 33 | (index (string-contains s substring))) 34 | (if (not (equal? index #f)) 35 | (let ((replaced (string-replace newstring replacement index (+ index sublen)))) 36 | (replacer replaced (string-contains replaced substring index ))); only look at parts after index 37 | newstring)))) 38 | 39 | 40 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 41 | ; 1.044660s real time, 1.042901s run time. 0.761600s spent in GC. 42 | (define (string-replace-substring/addindex s substring replacement) 43 | "Replace every instance of substring in s by replacement." 44 | (let ((sublen (string-length substring))) 45 | (let replacer 46 | ((newstring s) 47 | (startindex 0) 48 | (addindex (string-contains s substring))) 49 | (if (not (equal? addindex #f)) 50 | (let* 51 | ((index (+ startindex addindex)) 52 | (replaced (string-replace newstring replacement index (+ index sublen))) 53 | (newaddindex (string-contains (substring/read-only replaced index) substring))) 54 | (replacer replaced index newaddindex)) 55 | newstring)))) 56 | 57 | 58 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 59 | ; 7.547528s real time, 7.534397s run time. 0.764280s spent in GC. 60 | (define (string-replace-substring/naive s substring replacement) 61 | "Replace every instance of substring in s by replacement." 62 | (let ((sublen (string-length substring))) 63 | (let replacer 64 | ((newstring s) 65 | (index (string-contains s substring))) 66 | (if (not (equal? index #f)) 67 | (let ((replaced (string-replace newstring replacement index (+ index sublen)))) 68 | (replacer replaced (string-contains replaced substring))) 69 | newstring)))) 70 | 71 | 72 | -------------------------------------------------------------------------------- /examples/string-replace-benchmark.w: -------------------------------------------------------------------------------- 1 | define-module : examples string-replace-benchmark 2 | . #:export : string-replace-substring string-replace-substring/startindex string-replace-substring/addindex string-replace-substring/naive 3 | 4 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 5 | ; 0.010369s real time, 0.010348s run time. 0.000000s spent in GC. 6 | define* 7 | string-replace-substring s substr replacement 8 | . #:optional (start 0) (end (string-length s)) 9 | . "Replace every instance of substring in s by replacement." 10 | let : : substr-length : string-length substr 11 | if : zero? substr-length 12 | error "string-replace-substring: empty substr" 13 | let loop 14 | : start start 15 | pieces : list : substring s 0 start 16 | let : : idx : string-contains s substr start end 17 | if idx 18 | loop : + idx substr-length 19 | cons* replacement 20 | substring s start idx 21 | . pieces 22 | string-concatenate-reverse 23 | cons : substring s start 24 | . pieces 25 | 26 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 27 | ; 1.112429s real time, 1.083435s run time. 0.780863s spent in GC. 28 | define : string-replace-substring/startindex s substring replacement 29 | . "Replace every instance of substring in s by replacement." 30 | let : : sublen : string-length substring 31 | let replacer 32 | : newstring s 33 | index : string-contains s substring 34 | if : not : equal? index #f 35 | let : : replaced : string-replace newstring replacement index : + index sublen 36 | replacer replaced : string-contains replaced substring index ; only look at parts after index 37 | . newstring 38 | 39 | 40 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 41 | ; 1.044660s real time, 1.042901s run time. 0.761600s spent in GC. 42 | define : string-replace-substring/addindex s substring replacement 43 | . "Replace every instance of substring in s by replacement." 44 | let : : sublen : string-length substring 45 | let replacer 46 | : newstring s 47 | startindex 0 48 | addindex : string-contains s substring 49 | if : not : equal? addindex #f 50 | let* 51 | : index : + startindex addindex 52 | replaced : string-replace newstring replacement index : + index sublen 53 | newaddindex : string-contains (substring/read-only replaced index) substring 54 | replacer replaced index newaddindex 55 | . newstring 56 | 57 | 58 | ; ,time (string-replace-substring (xsubstring "abcdefghijkl" 0 99999) "def" "abc") 59 | ; 7.547528s real time, 7.534397s run time. 0.764280s spent in GC. 60 | define : string-replace-substring/naive s substring replacement 61 | . "Replace every instance of substring in s by replacement." 62 | let : : sublen : string-length substring 63 | let replacer 64 | : newstring s 65 | index : string-contains s substring 66 | if : not : equal? index #f 67 | let : : replaced : string-replace newstring replacement index : + index sublen 68 | replacer replaced : string-contains replaced substring 69 | . newstring 70 | -------------------------------------------------------------------------------- /examples/threaded-writing.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | # set Guile if unset 4 | if [ -z ${GUILE+x} ]; then 5 | GUILE=guile 6 | fi 7 | echo ${GUILE} 8 | "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 9 | exec -a "$0" "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples threaded-writing)' -c '' "$@" 10 | ; !# 11 | 12 | define-module : examples threaded-writing 13 | . #:export : main 14 | 15 | import : ice-9 threads 16 | 17 | define : help args 18 | format #t "~a [--help] [--test]\n" (car args) 19 | 20 | define : write-threaded args 21 | define status-output-mutex : make-mutex 22 | 23 | define : status-message msg i 24 | lock-mutex status-output-mutex 25 | format #t "~d ~a\n" i msg 26 | unlock-mutex status-output-mutex 27 | 28 | par-map status-message args : iota : length args 29 | 30 | 31 | define : main args 32 | cond 33 | : and {(length args) > 1} : equal? "--help" : car : cdr args 34 | help args 35 | else 36 | write-threaded args 37 | -------------------------------------------------------------------------------- /examples/timeit.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | # -*- wisp -*- 3 | exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples timeit) main)' -s "$0" "$@" 4 | ; !# 5 | 6 | ;; Timeit: NIH Easy benchmarking of code in guile 7 | 8 | define-module : examples timeit 9 | . #:exports : timeit timeit-fun 10 | 11 | use-modules : ice-9 match 12 | 13 | define* : timeit-fun #:key (fun (lambda () #f)) (let #f) (subtract #f) 14 | fun 15 | 16 | define-syntax-rule : timeit pattern ... 17 | let matcher 18 | : pattern pattern 19 | args '() 20 | if : null? pattern 21 | timeit-fun args 22 | match pattern 23 | : '#:let c d ... 24 | matcher 25 | cons a d 26 | cons `(let . ,c) args 27 | : '#:subtract c d ... 28 | matcher 29 | cons a d 30 | cons `(subtract . ,c) args 31 | : a 32 | let : : fun : lambda () a 33 | matcher '() 34 | cons `(fun . ,fun) args 35 | -------------------------------------------------------------------------------- /examples/tinyenc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | void encrypt (uint32_t* v, uint32_t* k) { 5 | uint32_t v0=v[0], v1=v[1], sum=0, i; /* set up */ 6 | uint32_t delta=0x9e3779b9; /* a key schedule constant */ 7 | uint32_t k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ 8 | for (i=0; i < 32; i++) { /* basic cycle start */ 9 | sum += delta; 10 | // printf("v0: %u, v1: %u\n", v0, v1); 11 | // printf("sum: %u, (v1<<4) + k0: %u, (v1 + sum): %u, (v1>>5) + k1: %u\n", sum, ((v1<<4) + k0), (v1 + sum), ((v1>>5) + k1)); 12 | v0 += ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); 13 | v1 += ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); 14 | } /* end cycle */ 15 | // printf("v0: %u, v1: %u\n", v0, v1); 16 | // printf("k0: %u, k1: %u, k2: %u, k3: %u\n", k0, k1, k2, k3); 17 | v[0]=v0; v[1]=v1; 18 | } 19 | 20 | void decrypt (uint32_t* v, uint32_t* k) { 21 | uint32_t v0=v[0], v1=v[1], sum=0xC6EF3720, i; /* set up */ 22 | uint32_t delta=0x9e3779b9; /* a key schedule constant */ 23 | uint32_t k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */ 24 | for (i=0; i<32; i++) { /* basic cycle start */ 25 | v1 -= ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); 26 | v0 -= ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1); 27 | sum -= delta; 28 | } /* end cycle */ 29 | v[0]=v0; v[1]=v1; 30 | } 31 | 32 | int main () 33 | { 34 | uint32_t v[] = {0, 5}; 35 | uint32_t k[] = {0, 0, 0, 9}; 36 | int i; 37 | uint32_t res = 0; 38 | // performance test 39 | for (i=0; i<10000000; i++) // 10^7! 40 | { 41 | encrypt(v, k); 42 | res += v[1]; // avoid optimizing this loop away. 43 | decrypt(v, k); 44 | res += v[1]; 45 | } 46 | printf("res: %u, v1: %u\n", res, v[1]); 47 | return 0; 48 | } 49 | -------------------------------------------------------------------------------- /examples/tinyenc.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | (define-module (examples tinyenc) 8 | #:export (encrypt decrypt)) 9 | ; . #:use-syntax : ice-9 syncase 10 | ; `use-syntax' is deprecated. For compatibility with old and new guile I therefore need this. 11 | ; Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary. 12 | ; use-syntax : ice-9 syncase 13 | 14 | ; http://en.wikipedia.org/wiki/Tiny_Encryption_Algorithm#toctitle 15 | 16 | (define delta #x9e3779b9) 17 | (define uint32-limit #x100000000 ); 2**32 18 | (define uint32-max #xFFFFFFFF ); 2**32 - 1 19 | 20 | ; define-inlinable makes this much faster (30%!). 21 | (define-inlinable (uint32 number) 22 | "ensure that the number fits a uint32" 23 | ; instead of modulo, use bitwise and: simply throws out the higher bits 24 | (logand number uint32-max)) 25 | 26 | (define-inlinable (v0change k0 v1 sum k1) 27 | (logxor 28 | (+ k0 (ash v1 4)) 29 | (+ v1 sum) 30 | (+ k1 (uint32 (ash v1 -5))))) 31 | 32 | (define-inlinable (v1change k2 v0 sum k3) 33 | (logxor 34 | (+ k2 (ash v0 4)) 35 | (+ v0 sum) 36 | (+ k3 (uint32 (ash v0 -5))))) 37 | 38 | ; Define a macro with-split-kv which executes its body with let bindings to k0 k1 k2 k3 v0 and v1 39 | ; Use syntax-case to be able to break hygiene. 40 | ; http://www.gnu.org/software/guile/manual/html_node/Syntax-Case.html#index-with_002dsyntax 41 | (define-syntax with-split-vk 42 | (lambda (x) 43 | (syntax-case x () 44 | ((with-split-vk v k exp exp* ...) 45 | (with-syntax 46 | ((k0 (datum->syntax x 'k0)) 47 | (k1 (datum->syntax x 'k1)) 48 | (k2 (datum->syntax x 'k2)) 49 | (k3 (datum->syntax x 'k3)) 50 | (v0 (datum->syntax x 'v0)) 51 | (v1 (datum->syntax x 'v1))) 52 | #'(let 53 | ((v0 (uint32 (ash v -32))) 54 | (v1 (uint32 v)) 55 | (k0 (uint32 (ash k -96))) 56 | (k1 (uint32 (ash k -64))) 57 | (k2 (uint32 (ash k -32))) 58 | (k3 (uint32 k))) 59 | exp exp* ...)))))) 60 | 61 | 62 | (define (encrypt v k) 63 | "Encrypt the 64bit (8 byte, big endian) value V with the 128bit key K (16 byte)." 64 | (with-split-vk v k 65 | (let loop 66 | ((sum delta) 67 | (cycle 0) 68 | (v0 v0) 69 | (v1 v1)) 70 | (if (= cycle 32) 71 | (+ v1 (* v0 uint32-limit)) 72 | (let ((v0tmp (uint32 (+ v0 (v0change k0 v1 sum k1))))) 73 | (loop 74 | (uint32 (+ sum delta)) 75 | (+ cycle 1) 76 | v0tmp 77 | (uint32 (+ v1 (v1change k2 v0tmp sum k3))))))))) 78 | 79 | (define (decrypt v k) 80 | "Decrypt the 64bit (8 byte, big endian) value V with the 128bit key K (16 byte)." 81 | (with-split-vk v k 82 | (let loop 83 | ((sum #xc6ef3720) 84 | (cycle 0) 85 | (v0 v0) 86 | (v1 v1)) 87 | (if (= cycle 32) 88 | (+ v1 (* v0 uint32-limit)) 89 | ; (x-y) mod N is the same as (x mod N) - (y mod N) 90 | (let ((v1tmp (uint32 (- v1 (v1change k2 v0 sum k3))))) 91 | (loop 92 | (uint32 (- sum delta)) 93 | (+ cycle 1) 94 | (uint32 (- v0 (v0change k0 v1tmp sum k1))) 95 | v1tmp)))))) 96 | 97 | 98 | (format #t "decrypted: ~A\n" 99 | (decrypt 100 | (encrypt 101 | 5 102 | 9) 103 | 9)) 104 | (format #t "encrypted: ~A\n" 105 | (encrypt 106 | 5 107 | 9)) 108 | 109 | ; Performance test 110 | (define (testdecrypt ) 111 | (decrypt 112 | (encrypt 113 | 5 114 | 9) 115 | 9)) 116 | 117 | (let loop ((step 0)) 118 | (when (< step 100000 ); 10^5 119 | (testdecrypt) 120 | (loop (1+ step)))) 121 | 122 | 123 | -------------------------------------------------------------------------------- /examples/tinyenc.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples tinyenc)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples tinyenc 8 | . #:export : encrypt decrypt main 9 | ; . #:use-syntax : ice-9 syncase 10 | ; `use-syntax' is deprecated. For compatibility with old and new guile I therefore need this. 11 | ; Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary. 12 | ; use-syntax : ice-9 syncase 13 | 14 | ; http://en.wikipedia.org/wiki/Tiny_Encryption_Algorithm#toctitle 15 | 16 | define delta #x9e3779b9 17 | define uint32-limit #x100000000 ; 2**32 18 | define uint32-max #xFFFFFFFF ; 2**32 - 1 19 | 20 | ; define-inlinable makes this much faster (30%!). 21 | define-inlinable : uint32 number 22 | . "ensure that the number fits a uint32" 23 | ; instead of modulo, use bitwise and: simply throws out the higher bits 24 | logand number uint32-max 25 | 26 | define-inlinable : v0change k0 v1 sum k1 27 | logxor 28 | + k0 : ash v1 4 29 | + v1 sum 30 | + k1 : uint32 : ash v1 -5 31 | 32 | define-inlinable : v1change k2 v0 sum k3 33 | logxor 34 | + k2 : ash v0 4 35 | + v0 sum 36 | + k3 : uint32 : ash v0 -5 37 | 38 | ; Define a macro with-split-kv which executes its body with let bindings to k0 k1 k2 k3 v0 and v1 39 | ; Use syntax-case to be able to break hygiene. 40 | ; http://www.gnu.org/software/guile/manual/html_node/Syntax-Case.html#index-with_002dsyntax 41 | define-syntax with-split-vk 42 | lambda : x 43 | syntax-case x : 44 | : with-split-vk v k exp exp* ... 45 | with-syntax 46 | : k0 : datum->syntax x 'k0 47 | k1 : datum->syntax x 'k1 48 | k2 : datum->syntax x 'k2 49 | k3 : datum->syntax x 'k3 50 | v0 : datum->syntax x 'v0 51 | v1 : datum->syntax x 'v1 52 | #' let 53 | : v0 : uint32 : ash v -32 54 | v1 : uint32 v 55 | k0 : uint32 : ash k -96 56 | k1 : uint32 : ash k -64 57 | k2 : uint32 : ash k -32 58 | k3 : uint32 k 59 | . exp exp* ... 60 | 61 | 62 | define : encrypt v k 63 | . "Encrypt the 64bit (8 byte, big endian) value V with the 128bit key K (16 byte)." 64 | with-split-vk v k 65 | let loop 66 | : sum delta 67 | cycle 0 68 | v0 v0 69 | v1 v1 70 | if : = cycle 32 71 | + v1 : * v0 uint32-limit 72 | let : : v0tmp : uint32 : + v0 : v0change k0 v1 sum k1 73 | loop 74 | uint32 : + sum delta 75 | + cycle 1 76 | . v0tmp 77 | uint32 : + v1 : v1change k2 v0tmp sum k3 78 | 79 | define : decrypt v k 80 | . "Decrypt the 64bit (8 byte, big endian) value V with the 128bit key K (16 byte)." 81 | with-split-vk v k 82 | let loop 83 | : sum #xc6ef3720 84 | cycle 0 85 | v0 v0 86 | v1 v1 87 | if : = cycle 32 88 | + v1 : * v0 uint32-limit 89 | ; (x-y) mod N is the same as (x mod N) - (y mod N) 90 | let : : v1tmp : uint32 : - v1 : v1change k2 v0 sum k3 91 | loop 92 | uint32 : - sum delta 93 | + cycle 1 94 | uint32 : - v0 : v0change k0 v1tmp sum k1 95 | . v1tmp 96 | 97 | 98 | ; Performance test 99 | define : testdecrypt 100 | decrypt 101 | encrypt 102 | . 5 103 | . 9 104 | . 9 105 | 106 | define : main args 107 | let loop : : step 0 108 | when : < step 100000 ; 10^5 109 | testdecrypt 110 | loop : 1+ step 111 | 112 | format #t "decrypted: ~A\n" 113 | decrypt 114 | encrypt 115 | . 5 116 | . 9 117 | . 9 118 | format #t "encrypted: ~A\n" 119 | encrypt 120 | . 5 121 | . 9 122 | 123 | -------------------------------------------------------------------------------- /examples/triangle.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | # set Guile if unset 4 | if [ -z ${GUILE+x} ]; then 5 | GUILE=guile 6 | fi 7 | "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 2>/dev/null 1>/dev/null 8 | exec -a "$0" "${GUILE}" -L $(dirname $(dirname $(realpath "$0"))) -x .w --language=wisp -e '(examples triangle)' -c '' "$@" 2>/dev/null 9 | ; !# 10 | 11 | ;;; Just converted for fun from the OCaml solution by Andrew Kensler 12 | ;;; at 13 | ;;; http://www.frank-buss.de/challenge/solutions/andrew-func.ml.html 14 | ;;; for the triangle counting challenge 15 | ;;; http://www.frank-buss.de/challenge/index.html 16 | 17 | define-module : examples triangle 18 | . #:export : main 19 | 20 | define : count_func lsides rsides 21 | define rsides-1 {rsides - 1} 22 | define lsides-1 {lsides - 1} 23 | let loop : (ls 0) (rs 0) (le 0) (re 0) (total 0) 24 | define new_tot 25 | if : or {ls = 0} {rs = 0} 26 | . {total + 1} total 27 | cond 28 | {re < rsides-1} : loop ls rs le { re + 1 } new_tot 29 | {le < lsides-1} : loop ls rs { le + 1 } rs new_tot 30 | {rs < rsides-1} : loop ls { rs + 1 } ls { rs + 1 } new_tot 31 | {ls < lsides-1} : loop { ls + 1 } 0 { ls + 1 } 0 new_tot 32 | else new_tot 33 | 34 | define : main args 35 | display : count_func 3 3 36 | newline 37 | -------------------------------------------------------------------------------- /examples/unbiased-std.scm: -------------------------------------------------------------------------------- 1 | (define-module (example unbiased-std) 2 | #:export (std)) 3 | 4 | (define factors⁻¹ 5 | '(;; from https://en.wikipedia.org/wiki/Unbiased_estimation_of_standard_deviation#Results_for_the_normal_distribution 6 | (2 . 0.7978845608) 7 | (3 . 0.8862269255) 8 | (4 . 0.9213177319) 9 | (5 . 0.9399856030) 10 | (6 . 0.9515328619) 11 | (7 . 0.9593687891) 12 | (8 . 0.9650304561) 13 | (9 . 0.9693106998) 14 | (10 . 0.9726592741))) 15 | 16 | (define (std . vals) 17 | "Calculate the unbiased standard deviation of the values (the biased std for more than 10 values)." 18 | (let ((len (length vals))) 19 | (if (< len 2) 20 | +inf.0 21 | (let 22 | ((mean (/ (apply + vals) len)) 23 | (factor (or (assoc-ref factors⁻¹ len) 1))) 24 | (* (/ 1 factor) (sqrt (* (/ 1 (- len 1)) (apply + (map (λ(x) (expt (- x mean) 2)) vals .))))))))) 25 | 26 | ;; quick test 27 | (let ((res (std 0 0 3))) 28 | (when (not (> 0.01 (abs (- res (* 1.129 (sqrt 3 ))))));; calculated by hand 29 | (format #t "Bug: (std 0 0 3) gives ~a instead of 1.995\n" res))) 30 | 31 | (write (std 5860.16 6141.81 6088.67)) 32 | 33 | 34 | -------------------------------------------------------------------------------- /examples/unbiased-std.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples unbiased-std)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples unbiased-std 8 | . #:export : std main 9 | 10 | define factors⁻¹ 11 | ' ;; from https://en.wikipedia.org/wiki/Unbiased_estimation_of_standard_deviation#Results_for_the_normal_distribution 12 | 2 . 0.7978845608 13 | 3 . 0.8862269255 14 | 4 . 0.9213177319 15 | 5 . 0.9399856030 16 | 6 . 0.9515328619 17 | 7 . 0.9593687891 18 | 8 . 0.9650304561 19 | 9 . 0.9693106998 20 | 10 . 0.9726592741 21 | 22 | define : std . vals 23 | . "Calculate the unbiased standard deviation of the values (the biased std for more than 10 values)." 24 | let : : len : length vals 25 | if : < len 2 26 | . +inf.0 27 | let 28 | : mean (/ (apply + vals) len) 29 | factor (or (assoc-ref factors⁻¹ len) 1) 30 | * (/ 1 factor) : sqrt : * (/ 1 (- len 1)) : apply + : map (λ(x) (expt (- x mean) 2)) vals . 31 | 32 | define : main args 33 | ;; quick test 34 | let : : res : std 0 0 3 35 | when : not : > 0.01 : abs : - res : * 1.129 : sqrt 3 ;; calculated by hand 36 | format #t "Bug: (std 0 0 3) gives ~a instead of 1.995\n" res 37 | 38 | write : std 5860.16 6141.81 6088.67 39 | newline 40 | -------------------------------------------------------------------------------- /examples/unicode-math-fun.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -s "$0" "$@") 5 | ; !# 6 | 7 | ;; Having fun with unicode and math :) 8 | 9 | (define (Σ . n) 10 | (apply + n)) 11 | 12 | (define (Π . n) 13 | (apply * n)) 14 | 15 | (define (∪ . lists) 16 | (apply append lists)) 17 | 18 | (define (∩ list1 list2) 19 | (let ((h (make-hash-table (length list2)))) 20 | (let fill ((toadd list2)) 21 | (when (not (equal? toadd '())) 22 | (hash-set! h (list-ref toadd 0) #t) 23 | (fill (list-tail toadd 1)))) 24 | (let loop ((inboth '()) (tocheck list1)) 25 | (if (equal? tocheck '()) 26 | inboth 27 | (let ((cur (list-ref tocheck 0))) 28 | (if (hash-ref h cur) 29 | (loop 30 | (append inboth (list cur)) 31 | (list-tail tocheck 1)) 32 | (loop inboth (list-tail tocheck 1)))))))) 33 | 34 | (display (Σ 1 2 8 0 5 7 59 12 5)) 35 | (newline) 36 | (display (Π 1 2 8 0 5 7 59 12 5)) 37 | (newline) 38 | (display (∪ '(1 2 3) '(4 5 6))) 39 | (newline) 40 | (display (∩ '(1 789 7 897 89 78 78 97 89 2 3 6) '(4 5 6 2 8 7 879 879 879 879 8797 97 97 987 89789 7 7897 987 897 987 87 897 896))) 41 | (newline) 42 | 43 | 44 | -------------------------------------------------------------------------------- /examples/unicode-math-fun.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples unicode-math-fun)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples unicode-math-fun 8 | . #:export : main 9 | 10 | ;; Having fun with unicode and math :) 11 | 12 | define : Σ . n 13 | apply + n 14 | 15 | define : Π . n 16 | apply * n 17 | 18 | define : ∪ . lists 19 | apply append lists 20 | 21 | define : ∩ list1 list2 22 | let : : h : make-hash-table : length list2 23 | let fill : : toadd list2 24 | when : not : equal? toadd '() 25 | hash-set! h (list-ref toadd 0) #t 26 | fill : list-tail toadd 1 27 | let loop : (inboth '()) (tocheck list1) 28 | if : equal? tocheck '() 29 | . inboth 30 | let : : cur : list-ref tocheck 0 31 | if : hash-ref h cur 32 | loop 33 | append inboth : list cur 34 | list-tail tocheck 1 35 | loop inboth : list-tail tocheck 1 36 | 37 | define : main args 38 | display : Σ 1 2 8 0 5 7 59 12 5 39 | newline 40 | display : Π 1 2 8 0 5 7 59 12 5 41 | newline 42 | display : ∪ '(1 2 3) '(4 5 6) 43 | newline 44 | display : ∩ '(1 789 7 897 89 78 78 97 89 2 3 6) '(4 5 6 2 8 7 879 879 879 879 8797 97 97 987 89789 7 7897 987 897 987 87 897 896) 45 | newline 46 | -------------------------------------------------------------------------------- /examples/with.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples with) main)' -s "$0" "$@") 4 | ; !# 5 | 6 | ;; A cleaner way to implement this might be using dynamic-wind. 7 | 8 | ;; FIXME: This might not be continuation-safe and might break if the 9 | ;; code in the with block uses dynamic-wind. Check whether it’s safe 10 | ;; and fix it if not. 11 | 12 | (define-module (examples with)) 13 | 14 | (import (oop goops)) 15 | 16 | (define (enter thing state) 17 | thing) 18 | (define-generic enter) 19 | 20 | (define (exit thing state) 21 | thing) 22 | (define-generic exit) 23 | 24 | (define-syntax with 25 | (syntax-rules (as) 26 | ((_ thing as name thunk ...) 27 | (let 28 | ((name #f) 29 | (state #f) 30 | (res #f)) 31 | (dynamic-wind 32 | (λ () (set! name (enter thing state))) 33 | (λ () (set! res (begin thunk ...)) 34 | res) 35 | (λ () ; : exit thing state 36 | res)))))) 37 | 38 | (define-method (enter (thing ) state) 39 | "Ensure that a port is always closed at the end of the with-block." 40 | (when (not (equal? #f state)) 41 | (set-port-column! thing (car state)) 42 | (set-port-line! thing (car (cdr state)))) 43 | thing) 44 | 45 | (define-method (exit (thing ) state) 46 | "Ensure that a port is always closed at the end of the with-block." 47 | (set! state (list (port-line thing) (port-column thing))) 48 | (close-port thing)) 49 | 50 | (define (main args) 51 | (with (open-file "with.w" "r") as port 52 | (format #t "~a\n" (read port)) 53 | (format #t "~a\n" (read port)) 54 | (format #t "~a\n" (read port)))) 55 | 56 | ;; TODO: test-continuation 57 | 58 | 59 | -------------------------------------------------------------------------------- /examples/with.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples with)' -c '' "$@" 4 | ; !# 5 | 6 | ;; A cleaner way to implement this might be using dynamic-wind. 7 | 8 | ;; FIXME: This might not be continuation-safe and might break if the 9 | ;; code in the with block uses dynamic-wind. Check whether it’s safe 10 | ;; and fix it if not. 11 | 12 | define-module : examples with 13 | . #:export : main 14 | 15 | import : oop goops 16 | 17 | define : enter thing state 18 | . thing 19 | define-generic enter 20 | 21 | define : exit thing state 22 | . thing 23 | define-generic exit 24 | 25 | define-syntax with 26 | syntax-rules : as 27 | : _ thing as name thunk ... 28 | let 29 | : name #f 30 | state #f 31 | res #f 32 | dynamic-wind 33 | λ () : set! name : enter thing state 34 | λ () : set! res : begin thunk ... 35 | . res 36 | λ () ; : exit thing state 37 | . res 38 | 39 | define-method : enter (thing ) state 40 | . "Ensure that a port is always closed at the end of the with-block." 41 | when : not : equal? #f state 42 | set-port-column! thing (car state) 43 | set-port-line! thing (car (cdr state)) 44 | . thing 45 | 46 | define-method : exit (thing ) state 47 | . "Ensure that a port is always closed at the end of the with-block." 48 | set! state : list (port-line thing) (port-column thing) 49 | close-port thing 50 | 51 | define : main args 52 | with (open-file "with.w" "r") as port 53 | format #t "~a\n" : read port 54 | format #t "~a\n" : read port 55 | format #t "~a\n" : read port 56 | 57 | ;; TODO: test-continuation 58 | -------------------------------------------------------------------------------- /examples/y-combinator.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | (# -*- wisp -*-) 3 | (guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))') 4 | (exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples y-combinator) main)' -s "$0" "$@") 5 | ; !# 6 | 7 | (define-module (examples y-combinator)) 8 | 9 | ;; Poor mans y-combinator from William Byrds talk: https://www.youtube.com/watch?v=OyfBQmvr2Hc&t=2844s 10 | (define fac-pmy-zealous-wisp 11 | ( 12 | (λ (!) 13 | (λ (n) 14 | ( 15 | (! !) 16 | n))) 17 | (λ (!) 18 | (λ (n) 19 | (if (zero? n) 20 | 1 21 | (* n 22 | ( 23 | (! !) 24 | (- n 1)))))))) 25 | 26 | (define fac-pmy-pragmatic-wisp 27 | ( 28 | (λ (!) 29 | (λ (n) 30 | ((! !) n))) 31 | (λ (!) 32 | (λ (n) 33 | (if (zero? n) 34 | 1 35 | (* n ((! !) {n - 1}))))))) 36 | 37 | 38 | ;; Poor mans y-combinator from William Byrds talk: https://www.youtube.com/watch?v=OyfBQmvr2Hc&t=2844s 39 | (define facres-pmy 40 | (((λ (!) 41 | (λ (n) 42 | ((! !) n))) 43 | (λ (!) 44 | (λ (n) 45 | (if (zero? n) 46 | 1 47 | (* n ((! !) (- n 1))))))) 48 | 5)) 49 | 50 | ;; from rosetta code: https://rosettacode.org/wiki/Y_combinator#Scheme 51 | (define Y 52 | (λ (h) 53 | ((λ (x) (x x)) 54 | (λ (g) 55 | (h (λ args (apply (g g) args))))))) 56 | 57 | (define fac 58 | (Y 59 | (λ (f) 60 | (λ (x) 61 | (if (< x 2) 62 | 1 63 | (* x (f (- x 1)))))))) 64 | 65 | (define fib 66 | (Y 67 | (λ (f) 68 | (λ (x) 69 | (if (< x 2) 70 | x 71 | (+ (f (- x 1)) 72 | (f (- x 2)))))))) 73 | 74 | 75 | (define (main args) 76 | (display (fac-pmy-zealous-wisp 5)) 77 | (newline) 78 | (display (fac-pmy-pragmatic-wisp 5)) 79 | (newline) 80 | (display facres-pmy) 81 | (newline) 82 | (display (fac 6)) 83 | (newline) 84 | (display (fib 6)) 85 | (newline)) 86 | 87 | 88 | -------------------------------------------------------------------------------- /examples/y-combinator.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples y-combinator)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples y-combinator 8 | . #:export : main 9 | 10 | ;; Poor mans y-combinator from William Byrds talk: https://www.youtube.com/watch?v=OyfBQmvr2Hc&t=2844s 11 | define fac-pmy-zealous-wisp 12 | : 13 | λ : ! 14 | λ : n 15 | : 16 | ! ! 17 | . n 18 | λ : ! 19 | λ : n 20 | if : zero? n 21 | . 1 22 | * n 23 | : 24 | ! ! 25 | - n 1 26 | 27 | define fac-pmy-pragmatic-wisp 28 | : 29 | λ : ! 30 | λ : n 31 | (! !) n 32 | λ : ! 33 | λ : n 34 | if : zero? n 35 | . 1 36 | * n : (! !) {n - 1} 37 | 38 | 39 | ;; Poor mans y-combinator from William Byrds talk: https://www.youtube.com/watch?v=OyfBQmvr2Hc&t=2844s 40 | define facres-pmy 41 | . (((λ (!) 42 | (λ (n) 43 | ((! !) n))) 44 | (λ (!) 45 | (λ (n) 46 | (if (zero? n) 47 | 1 48 | (* n ((! !) (- n 1))))))) 49 | 5) 50 | 51 | ;; from rosetta code: https://rosettacode.org/wiki/Y_combinator#Scheme 52 | define Y 53 | λ : h 54 | : λ (x) : x x 55 | λ : g 56 | h : λ args : apply (g g) args 57 | 58 | define fac 59 | Y 60 | λ : f 61 | λ : x 62 | if : < x 2 63 | . 1 64 | * x : f : - x 1 65 | 66 | define fib 67 | Y 68 | λ : f 69 | λ : x 70 | if : < x 2 71 | . x 72 | + : f : - x 1 73 | f : - x 2 74 | 75 | 76 | define : main args 77 | display : fac-pmy-zealous-wisp 5 78 | newline 79 | display : fac-pmy-pragmatic-wisp 5 80 | newline 81 | display facres-pmy 82 | newline 83 | display : fac 6 84 | newline 85 | display : fib 6 86 | newline 87 | -------------------------------------------------------------------------------- /examples/yinyang.scm: -------------------------------------------------------------------------------- 1 | ; from http://en.wikipedia.org/wiki/Scheme_%28programming_language%29 2 | (let* 3 | ( 4 | (yin 5 | ((lambda (cc) (display "@") cc) 6 | (call/cc (lambda (c) c)))) 7 | (yang 8 | ((lambda (cc) (display "*") cc ) 9 | (call/cc (lambda (c) c))))) 10 | (yin yang)) 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/yinyang.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))' 4 | exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(examples yinyang)' -c '' "$@" 5 | ; !# 6 | 7 | define-module : examples yinyang 8 | . #:export : main 9 | 10 | define : main args 11 | ;; from http://en.wikipedia.org/wiki/Scheme_%28programming_language%29 12 | let* 13 | : 14 | yin 15 | : lambda (cc) (display "@") cc 16 | call/cc : lambda (c) c 17 | yang 18 | : lambda (cc) (display "*") cc 19 | call/cc : lambda (c) c 20 | yin yang 21 | -------------------------------------------------------------------------------- /guildhall-packages/newbase60/pkg-list.scm: -------------------------------------------------------------------------------- 1 | (package (newbase60 (0)) 2 | (synopsis "Implementation of Tanteks New Base 60") 3 | (libraries 4 | (scm -> "newbase60")) 5 | (programs 6 | ("newbase60.scm"))) 7 | -------------------------------------------------------------------------------- /racket/wisp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Implement wisp in Racket 4 | ;; 5 | ;; -Author: Arne Babenhauserheide 6 | 7 | ; adapted from wisp-in-guile and algol60.rkt 8 | 9 | (require (for-syntax "parse-base.rkt")) 10 | 11 | (provide literal-wisp) 12 | 13 | 14 | (define-syntax (literal-wisp stx) 15 | (syntax-case stx () 16 | [(_ strs ...) 17 | (andmap (λ (x) (string? (syntax-e x))) 18 | (syntax->list (syntax (strs ...)))) 19 | 20 | (parse-wisp-port 21 | (open-input-string 22 | (apply 23 | string-append 24 | (map syntax-e (syntax->list #'(strs ...))))) 25 | (syntax-source stx))])) -------------------------------------------------------------------------------- /testrunner.w: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | exec guile -L . --language=wisp -s "$0" "$@" 3 | !# 4 | 5 | when : not : = 3 : length : command-line 6 | format #t "Usage: ~A \n" : list-ref (command-line) 0 7 | exit 8 | 9 | define wisp-file : list-ref (command-line) 1 10 | define scheme-file : list-ref (command-line) 2 11 | 12 | use-modules 13 | srfi srfi-1 14 | language wisp 15 | 16 | 17 | define : read-all port 18 | let readloop : : res : ' 19 | let : : next : read port 20 | if : eof-object? next 21 | . res 22 | readloop : append res : list next 23 | 24 | let 25 | : 26 | read-scheme 27 | with-input-from-file scheme-file 28 | λ () 29 | read-all : current-input-port 30 | parsed-wisp 31 | with-input-from-file wisp-file 32 | λ () 33 | wisp-scheme-read-all : current-input-port 34 | if : equal? parsed-wisp read-scheme 35 | format #t "Files ~A and ~A have equivalent content.\n" scheme-file wisp-file 36 | format #t "Files ~A and ~A are different!\n\nwisp: ~A\n\nscheme: ~A\n\n\n" scheme-file wisp-file parsed-wisp read-scheme 37 | -------------------------------------------------------------------------------- /tests/btest.scm: -------------------------------------------------------------------------------- 1 | (display "b") 2 | (newline) 3 | 4 | 5 | -------------------------------------------------------------------------------- /tests/btest.w: -------------------------------------------------------------------------------- 1 | display "b" 2 | newline 3 | -------------------------------------------------------------------------------- /tests/continuation.scm: -------------------------------------------------------------------------------- 1 | (a b c d e 2 | f g h 3 | i j k) 4 | 5 | (concat "I want " 6 | (getwish from me) 7 | " - " username) 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /tests/continuation.w: -------------------------------------------------------------------------------- 1 | a b c d e 2 | . f g h 3 | . i j k 4 | 5 | concat "I want " 6 | getwish from me 7 | . " - " username 8 | 9 | -------------------------------------------------------------------------------- /tests/dotted-pair.scm: -------------------------------------------------------------------------------- 1 | (use-modules ((ice-9 popen) #:select ((open-input-pipe . oip)))) 2 | 3 | 4 | -------------------------------------------------------------------------------- /tests/dotted-pair.w: -------------------------------------------------------------------------------- 1 | use-modules : (ice-9 popen) #:select ((open-input-pipe . oip)) 2 | -------------------------------------------------------------------------------- /tests/emacs-customization-tex-master.scm: -------------------------------------------------------------------------------- 1 | (defun guess-TeX-master (filename) 2 | "Guess the master file for FILENAME from currently open .tex files." 3 | (let 4 | ( 5 | (candidate nil) 6 | (filename (file-name-nondirectory filename))) 7 | (save-excursion 8 | (dolist (buffer (buffer-list)) 9 | (with-current-buffer buffer 10 | 11 | (let 12 | ( 13 | (name (buffer-name)) 14 | (file buffer-file-name)) 15 | (if 16 | (and file (string-match "\\.tex$" file)) 17 | 18 | (progn 19 | (goto-char (point-min)) 20 | (if 21 | (re-search-forward 22 | (concat "\\\\input{" filename "}") 23 | nil t) 24 | (setq candidate file)) 25 | (if 26 | (re-search-forward 27 | (concat "\\\\include{" (file-name-sans-extension filename) "}") 28 | nil t) 29 | (setq candidate file)))))))) 30 | 31 | (if candidate 32 | (message "TeX master document: %s" (file-name-nondirectory candidate))) 33 | candidate)) 34 | 35 | 36 | -------------------------------------------------------------------------------- /tests/emacs-customization-tex-master.w: -------------------------------------------------------------------------------- 1 | defun guess-TeX-master : filename 2 | . "Guess the master file for FILENAME from currently open .tex files." 3 | let 4 | : 5 | candidate nil 6 | filename : file-name-nondirectory filename 7 | save-excursion 8 | dolist : buffer : buffer-list 9 | with-current-buffer buffer 10 | 11 | let 12 | : 13 | name : buffer-name 14 | file buffer-file-name 15 | if 16 | and file : string-match "\\.tex$" file 17 | 18 | progn 19 | goto-char : point-min 20 | if 21 | re-search-forward 22 | concat "\\\\input{" filename "}" 23 | . nil t 24 | setq candidate file 25 | if 26 | re-search-forward 27 | concat "\\\\include{" (file-name-sans-extension filename) "}" 28 | . nil t 29 | setq candidate file 30 | 31 | if candidate 32 | message "TeX master document: %s" : file-name-nondirectory candidate 33 | . candidate 34 | -------------------------------------------------------------------------------- /tests/emacs-customization.scm: -------------------------------------------------------------------------------- 1 | (if (file-directory-p "~/.emacs.d/private/journal/") 2 | (setq-default journal-dir "~/.emacs.d/private/journal/")) 3 | 4 | ; the following line is not valid scheme and as such would break the scheme tests. 5 | ; global-set-key [(control meta .)] 'goto-last-change-reverse 6 | 7 | (require 'org-latex) 8 | (add-to-list 'org-export-latex-packages-alist 9 | '("" "minted")) 10 | 11 | (add-to-list 'org-export-latex-packages-alist 12 | '("" "color")) 13 | 14 | (setq org-export-latex-listings 'minted) 15 | 16 | (add-hook 'outline-mode-hook 17 | (lambda () 18 | (require 'outline-magic))) 19 | 20 | 21 | (defun find-file-as-root () 22 | "Like `ido-find-file, but automatically edit the file with 23 | root-privileges (using tramp/sudo), if the file is not writable by 24 | user." 25 | (interactive) 26 | (let ((file (ido-read-file-name "Edit as root: "))) 27 | (unless (file-writable-p file) 28 | (setq file (concat find-file-root-prefix file))) 29 | (find-file file))) 30 | 31 | (defun find-current-as-root () 32 | "Reopen current file as root" 33 | (interactive) 34 | (set-visited-file-name (concat find-file-root-prefix (buffer-file-name))) 35 | (setq buffer-read-only nil)) 36 | 37 | ; the next function definition is equivalent, due to inline : 38 | 39 | (defun find-current-as-root () 40 | "Reopen current file as root" 41 | (interactive) 42 | (set-visited-file-name 43 | (concat find-file-root-prefix 44 | (buffer-file-name))) 45 | (setq buffer-read-only nil)) 46 | 47 | (custom-set-variables 48 | ;; custom-set-variables was added by Custom. 49 | ;; If you edit it by hand, you could mess it up, so be careful. 50 | ;; Your init file should contain only one such instance. 51 | ;; If there is more than one, they won't work right. 52 | '(bbdb-complete-name-allow-cycling t) 53 | '(bbdb-ignore-some-messages-alist (quote (("From" . "mailer-daemon")))) 54 | '(bbdb-offer-save (quote savenoprompt))) 55 | 56 | 57 | (setq a "x" 58 | b "y" 59 | c "z") 60 | 61 | -------------------------------------------------------------------------------- /tests/emacs-customization.w: -------------------------------------------------------------------------------- 1 | if : file-directory-p "~/.emacs.d/private/journal/" 2 | setq-default journal-dir "~/.emacs.d/private/journal/" 3 | 4 | ; the following line is not valid scheme and as such would break the scheme tests. 5 | ; global-set-key [(control meta .)] 'goto-last-change-reverse 6 | 7 | require 'org-latex 8 | add-to-list 'org-export-latex-packages-alist 9 | ' "" "minted" 10 | 11 | add-to-list 'org-export-latex-packages-alist 12 | ' "" "color" 13 | 14 | setq org-export-latex-listings 'minted 15 | 16 | add-hook 'outline-mode-hook 17 | lambda : 18 | require 'outline-magic 19 | 20 | 21 | defun find-file-as-root : 22 | . "Like `ido-find-file, but automatically edit the file with 23 | root-privileges (using tramp/sudo), if the file is not writable by 24 | user." 25 | interactive 26 | let : : file : ido-read-file-name "Edit as root: " 27 | unless : file-writable-p file 28 | setq file : concat find-file-root-prefix file 29 | find-file file 30 | 31 | defun find-current-as-root : 32 | . "Reopen current file as root" 33 | interactive 34 | set-visited-file-name : concat find-file-root-prefix : buffer-file-name 35 | setq buffer-read-only nil 36 | 37 | ; the next function definition is equivalent, due to inline : 38 | 39 | defun find-current-as-root : 40 | . "Reopen current file as root" 41 | interactive 42 | set-visited-file-name 43 | concat find-file-root-prefix 44 | buffer-file-name 45 | setq buffer-read-only nil 46 | 47 | custom-set-variables 48 | ;; custom-set-variables was added by Custom. 49 | ;; If you edit it by hand, you could mess it up, so be careful. 50 | ;; Your init file should contain only one such instance. 51 | ;; If there is more than one, they won't work right. 52 | ' bbdb-complete-name-allow-cycling t 53 | ' bbdb-ignore-some-messages-alist : quote : ("From" . "mailer-daemon") 54 | ' bbdb-offer-save : quote savenoprompt 55 | 56 | 57 | setq a "x" 58 | . b "y" 59 | . c "z" 60 | -------------------------------------------------------------------------------- /tests/example.scm: -------------------------------------------------------------------------------- 1 | (defun a (b c) 2 | (let 3 | ( 4 | (d "i am a string 5 | do not break me!") 6 | ( 7 | ; comment: 0 8 | (f) 9 | ; comment : 1 10 | `(g )); comment " : " 2 11 | ( 12 | (h (I am in brackets: 13 | do not : change "me")) 14 | i))) 15 | ,('j k) 16 | 17 | l 18 | 19 | ; comment 20 | 21 | (a c)) 22 | 23 | (defun b (:n o) 24 | "second defun : with a docstring!" 25 | (message "I am here") 26 | t) 27 | 28 | (defun c (e f) 29 | ((g)) 30 | ( 31 | (h 32 | (i)) 33 | (j)) 34 | '(()) 35 | (k) 36 | l 37 | (m)) 38 | 39 | (defun _ (:) 40 | 41 | :) 42 | 43 | (_ b) 44 | 45 | (defun d () 46 | (let 47 | ((a b) 48 | (c d)))) 49 | 50 | (a (((c)))) 51 | 52 | (let 53 | ((a b) 54 | (c))) 55 | 56 | (let ((a b))) 57 | 58 | a 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /tests/example.w: -------------------------------------------------------------------------------- 1 | defun a (b c) 2 | let 3 | : 4 | d "i am a string 5 | do not break me!" 6 | : 7 | ; comment: 0 8 | f 9 | ; comment : 1 10 | ` g ; comment " : " 2 11 | : 12 | h (I am in brackets: 13 | do not : change "me") 14 | . i 15 | , 'j k 16 | 17 | . l 18 | 19 | ; comment 20 | 21 | a c 22 | 23 | defun b : :n o 24 | . "second defun : with a docstring!" 25 | message "I am here" 26 | . t 27 | 28 | defun c : e f 29 | : g 30 | : 31 | h 32 | i 33 | j 34 | ' : 35 | k 36 | . l 37 | . : m 38 | 39 | defun _ : \: 40 | __ 41 | __ . \: 42 | 43 | \_ b 44 | 45 | defun d : 46 | let 47 | : a b 48 | c d 49 | 50 | a : : : c 51 | 52 | let 53 | : a b 54 | c 55 | 56 | let : : a b 57 | 58 | . a 59 | 60 | -------------------------------------------------------------------------------- /tests/factorial.scm: -------------------------------------------------------------------------------- 1 | ;; short version 2 | ; note: once you use one inline colon, all the following forms on that 3 | ; line will get closed at the end of the line 4 | 5 | (define (factorial n) 6 | (if (zero? n) 7 | 1 8 | (* n (factorial (- n 1))))) 9 | 10 | (display (factorial 5 )) 11 | 12 | 13 | ;; more vertical space, less colons 14 | (define (factorial n) 15 | (if (zero? n) 16 | 1 17 | (* n 18 | (factorial 19 | (- n 1))))) 20 | 21 | (display (factorial 5 )) 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /tests/factorial.w: -------------------------------------------------------------------------------- 1 | ;; short version 2 | ; note: once you use one inline colon, all the following forms on that 3 | ; line will get closed at the end of the line 4 | 5 | define : factorial n 6 | if : zero? n 7 | . 1 8 | * n : factorial : - n 1 9 | 10 | display : factorial 5 11 | 12 | 13 | ;; more vertical space, less colons 14 | define : factorial n 15 | if : zero? n 16 | . 1 17 | * n 18 | factorial 19 | - n 1 20 | 21 | display : factorial 5 22 | 23 | -------------------------------------------------------------------------------- /tests/fast-sum.scm: -------------------------------------------------------------------------------- 1 | (use-modules (srfi srfi-1)) 2 | 3 | ; only for the nice test 4 | #!curly-infix 5 | 6 | (define-syntax fast-sum 7 | (syntax-rules (iota) 8 | ((fast-sum (iota count start)) 9 | (+ 1 10 | (apply - 11 | (map (lambda (x) (/ {x * {x + 1} } 2)) 12 | (list {count + {start - 1}} start))))) 13 | ((fast-sum e) 14 | (apply + e)))) 15 | 16 | 17 | -------------------------------------------------------------------------------- /tests/fast-sum.w: -------------------------------------------------------------------------------- 1 | use-modules : srfi srfi-1 2 | 3 | ; only for the nice test 4 | . #!curly-infix 5 | 6 | define-syntax fast-sum 7 | syntax-rules : iota 8 | : fast-sum : iota count start 9 | + 1 10 | apply - 11 | map : lambda (x) : / {x * {x + 1} } 2 12 | list {count + {start - 1}} start 13 | : fast-sum e 14 | apply + e 15 | -------------------------------------------------------------------------------- /tests/flexible-parameter-list.scm: -------------------------------------------------------------------------------- 1 | ; Test using a . as first parameter on a line by prefixing it with a second . 2 | (define 3 | (a i 4 | . b) 5 | (unless (>= i (length b)) 6 | (display (number->string (length b ))) 7 | (display (list-ref b i)) 8 | (newline) 9 | (apply a ( + i 1 ) b))) 10 | 11 | 12 | (a 0 "123" "345" "567") 13 | 14 | 15 | -------------------------------------------------------------------------------- /tests/flexible-parameter-list.w: -------------------------------------------------------------------------------- 1 | ; Test using a . as first parameter on a line by prefixing it with a second . 2 | define 3 | a i 4 | . . b 5 | unless : >= i : length b 6 | display : number->string : length b 7 | display : list-ref b i 8 | newline 9 | apply a ( + i 1 ) b 10 | 11 | 12 | a 0 "123" "345" "567" 13 | -------------------------------------------------------------------------------- /tests/hello.scm: -------------------------------------------------------------------------------- 1 | (define (hello who) 2 | ;; include the newline 3 | (format #t "~A ~A!\n" 4 | "Hello" who)) 5 | (hello "Wisp") 6 | 7 | -------------------------------------------------------------------------------- /tests/hello.w: -------------------------------------------------------------------------------- 1 | define : hello who 2 | ;; include the newline 3 | format #t "~A ~A!\n" 4 | . "Hello" who 5 | hello "Wisp" 6 | -------------------------------------------------------------------------------- /tests/linebreaks.scm: -------------------------------------------------------------------------------- 1 | ; Test linebreaks in strings and brackets 2 | 3 | ("flubbub 4 | 5 | flabbab") 6 | 7 | (hrug (nadda 8 | madda gadda "shoktom 9 | mee" " sep 10 | ka" 11 | hadda) 12 | (gom)) 13 | 14 | (flu) 15 | 16 | 17 | -------------------------------------------------------------------------------- /tests/literalarray.scm: -------------------------------------------------------------------------------- 1 | #(a b) 2 | 3 | #( 4 | (a b)) 5 | -------------------------------------------------------------------------------- /tests/literalarray.w: -------------------------------------------------------------------------------- 1 | ## a b 2 | 3 | ## 4 | a b 5 | -------------------------------------------------------------------------------- /tests/mtest.scm: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh !# 2 | 3 | (display 1) 4 | 5 | 6 | -------------------------------------------------------------------------------- /tests/mtest.w: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh !# 2 | 3 | display 1 4 | -------------------------------------------------------------------------------- /tests/multiline-string.scm: -------------------------------------------------------------------------------- 1 | (display " 2 | This is a 3 | \"multi-line\" 4 | string. 5 | ") 6 | 7 | -------------------------------------------------------------------------------- /tests/multiline-string.w: -------------------------------------------------------------------------------- 1 | display " 2 | This is a 3 | \"multi-line\" 4 | string. 5 | " 6 | -------------------------------------------------------------------------------- /tests/namedlet.scm: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh 2 | ; !# 3 | (define (hello who) 4 | (display who)) 5 | 6 | (let hello 7 | ((who 0)) 8 | (if (= who 5) 9 | (display who) 10 | (hello (+ 1 who)))) 11 | 12 | 13 | -------------------------------------------------------------------------------- /tests/namedlet.w: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh 2 | ; !# 3 | define : hello who 4 | display who 5 | 6 | let hello 7 | : who 0 8 | if : = who 5 9 | display who 10 | hello : + 1 who 11 | -------------------------------------------------------------------------------- /tests/partial-indent.scm: -------------------------------------------------------------------------------- 1 | (write 2 | (list 3 | (+ 1 2) 4 | (+ 2 3))) 5 | (newline) 6 | 7 | (write 8 | (list 9 | (+ 1 2 10 | (+ 3 4)) 11 | (+ 2 3))) 12 | (newline) 13 | 14 | 15 | -------------------------------------------------------------------------------- /tests/partial-indent.w: -------------------------------------------------------------------------------- 1 | write 2 | list 3 | + 1 2 4 | + 2 3 5 | newline 6 | 7 | write 8 | list 9 | + 1 2 10 | + 3 4 11 | + 2 3 12 | newline 13 | -------------------------------------------------------------------------------- /tests/quotecolon.scm: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh 2 | ; !# 3 | (define a 1 ); test whether ' : correctly gets turned into '( 4 | ; and whether brackets in commments are treated correctly. 5 | 6 | (define a '(1 2 3)) 7 | 8 | (define 9 | (a b) 10 | (c)) 11 | 12 | (define a (quasiquote ,(+ 2 2))) 13 | -------------------------------------------------------------------------------- /tests/quotecolon.w: -------------------------------------------------------------------------------- 1 | #!/home/arne/wisp/wisp-multiline.sh 2 | ; !# 3 | define a 1 ; test whether ' : correctly gets turned into '( 4 | ; and whether brackets in commments are treated correctly. 5 | 6 | define a ' : 1 2 3 7 | 8 | define 9 | a b 10 | c 11 | 12 | define a : quasiquote , : + 2 2 13 | -------------------------------------------------------------------------------- /tests/range.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs)) 2 | 3 | (define range 4 | (case-lambda 5 | ((n ); one-argument syntax 6 | (range 0 n 1)) 7 | ((n0 n ); two-argument syntax 8 | (range n0 n 1)) 9 | ((n0 n s ); three-argument syntax 10 | (assert 11 | (and 12 | (for-all number? (list n0 n s)) 13 | (not (zero? s)))) 14 | (let ((cmp (if (positive? s) >= <= ))) 15 | (let loop 16 | ((i n0 ) 17 | (acc '())) 18 | (if 19 | (cmp i n ) 20 | (reverse acc) 21 | (loop (+ i s) (cons i acc)))))))) 22 | 23 | (display (apply string-append "" (map number->string (range 5)))) 24 | (newline) 25 | 26 | -------------------------------------------------------------------------------- /tests/range.w: -------------------------------------------------------------------------------- 1 | import : rnrs 2 | 3 | define range 4 | case-lambda 5 | : n ; one-argument syntax 6 | range 0 n 1 7 | : n0 n ; two-argument syntax 8 | range n0 n 1 9 | : n0 n s ; three-argument syntax 10 | assert 11 | and 12 | for-all number? : list n0 n s 13 | not : zero? s 14 | let : : cmp : if (positive? s) >= <= 15 | let loop 16 | : i n0 17 | acc '() 18 | if 19 | cmp i n 20 | reverse acc 21 | loop (+ i s) (cons i acc) 22 | 23 | display : apply string-append "" : map number->string : range 5 24 | newline -------------------------------------------------------------------------------- /tests/readable-tests.scm: -------------------------------------------------------------------------------- 1 | (define (fibfast n) 2 | (if (< n 2)) 3 | n 4 | (fibup n 2 1 0 )) 5 | 6 | (define (fibup maxnum count n-1 n-2) 7 | (if (= maxnum count) 8 | (+ n-1 n-2) 9 | (fibup maxnum 10 | (+ count 1 ) 11 | (+ n-1 n-2 ) 12 | n-1))) 13 | 14 | (define (factorial n) 15 | (if (<= n 1) 16 | 1 17 | (* n 18 | (factorial (- n 1))))) 19 | 20 | (define (gcd x y) 21 | (if (= y 0)) 22 | x 23 | (gcd y 24 | (rem x y))) 25 | 26 | (define (add-if-all-numbers lst) 27 | (call/cc 28 | (lambda (exit) 29 | (let loop 30 | ( 31 | (lst lst ) 32 | (sum 0)) 33 | (if (null? lst) 34 | sum 35 | (if (not (number? (car lst))) 36 | (exit #f) 37 | (+ (car lst) 38 | (loop (cdr lst))))))))) 39 | 40 | -------------------------------------------------------------------------------- /tests/readable-tests.w: -------------------------------------------------------------------------------- 1 | define : fibfast n 2 | if : < n 2 3 | . n 4 | fibup n 2 1 0 5 | 6 | define : fibup maxnum count n-1 n-2 7 | if : = maxnum count 8 | + n-1 n-2 9 | fibup maxnum 10 | + count 1 11 | + n-1 n-2 12 | . n-1 13 | 14 | define : factorial n 15 | if : <= n 1 16 | . 1 17 | * n 18 | factorial : - n 1 19 | 20 | define (gcd x y) 21 | if (= y 0) 22 | . x 23 | gcd y 24 | rem x y 25 | 26 | define : add-if-all-numbers lst 27 | call/cc 28 | lambda : exit 29 | let loop 30 | : 31 | lst lst 32 | sum 0 33 | if : null? lst 34 | . sum 35 | if : not : number? : car lst 36 | exit #f 37 | + : car lst 38 | loop : cdr lst -------------------------------------------------------------------------------- /tests/realpath.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # realpath implementation for systems which lack it (like OSX) 3 | if command -v realpath 2>/dev/null 1>/dev/null; then 4 | realpath "$@" 5 | elif command -v perl 2>/dev/null 1>/dev/null; then 6 | perl -MCwd -le 'print Cwd::realpath($ARGV[0])' "$@" 7 | else # fallback, though not getting out of a/../a 8 | [[ $1 = /* ]] && echo "$1" || echo "$PWD/${1#./}" 9 | fi 10 | -------------------------------------------------------------------------------- /tests/receive.scm: -------------------------------------------------------------------------------- 1 | (import (ice-9 receive) (srfi srfi-1)) 2 | (write 3 | (receive (car cdr) 4 | (car+cdr '(car . cdr)) 5 | car)) 6 | -------------------------------------------------------------------------------- /tests/receive.w: -------------------------------------------------------------------------------- 1 | import (ice-9 receive) (srfi srfi-1) 2 | write 3 | receive : car cdr 4 | car+cdr '(car . cdr) 5 | . car 6 | -------------------------------------------------------------------------------- /tests/runtests-scheme-preprocessor.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Simple test runner for wisp, mainly intended to be run by autotools. 4 | 5 | if [[ x"$1" == x"" || x"$1" == x"." ]]; then 6 | srcdir="$(pwd)" 7 | else 8 | srcdir="$1" 9 | fi 10 | 11 | if [[ x"$2" == x"" || x"$2" == x"." ]]; then 12 | builddir="$(pwd)" 13 | else 14 | builddir="$2" 15 | fi 16 | 17 | failed=0 18 | cd ${srcdir}/tests 19 | for i in *.w; do 20 | # skip strangecomments 21 | if test x"${i}" = x"strangecomments.w"; then continue; fi 22 | d=$(guile ${srcdir}/wisp.scm "$i" > ${builddir}/testtempfoo.scm; diff -wuB ${builddir}/testtempfoo.scm "$(basename "$i" .w)".scm; rm ${builddir}/testtempfoo.scm) 23 | if test x"$d" = x""; then 24 | continue 25 | else 26 | echo test "$i" failed. Diff: "$d" 27 | failed=1 28 | fi 29 | done 30 | cd - >/dev/null # undo dir change 31 | exit $failed 32 | -------------------------------------------------------------------------------- /tests/runtests-scheme-reader.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Simple test runner for wisp, mainly intended to be run by autotools. 4 | 5 | # FIXME: ./tests/realpath.sh currently encodes the path to the 6 | # command. AC_CONFIG_LINKS in autoconf.ac ensures that this exists in 7 | # the build dir. Still this could be nicer. 8 | 9 | # set Guile if unset 10 | if [ -z ${GUILE+x} ]; then 11 | GUILE=guile 12 | fi 13 | 14 | 15 | if [[ x"$1" == x"" || x"$1" == x"." ]]; then 16 | srcdir="$(./tests/realpath.sh "$(pwd)")" 17 | else 18 | srcdir="$(./tests/realpath.sh "$1")" 19 | fi 20 | 21 | if [[ x"$2" == x"" || x"$2" == x"." ]]; then 22 | builddir="$(./tests/realpath.sh $(pwd))" 23 | else 24 | builddir="$(./tests/realpath.sh "$2")" 25 | fi 26 | 27 | failed=0 28 | cd ${builddir} 29 | for i in ${srcdir}/tests/*.w; do 30 | if $GUILE -L ${builddir} --language=wisp ${srcdir}/testrunner.w "${i}" "${srcdir}/tests/$(basename "${i}" .w).scm" | grep -q "have equivalent content"; then 31 | continue 32 | fi 33 | echo test "$i" failed. Diff: $($GUILE -L ${builddir} --language=wisp ${srcdir}/testrunner.w "${i}" "${srcdir}/tests/$(basename "${i}" .w).scm") 34 | failed=$((failed + 1)) 35 | done 36 | cd - >/dev/null # undo dir change 37 | # if test $failed -eq 0; then echo "Tests succeeded"; 38 | # else echo "tests failed: ${failed}"; 39 | # fi 40 | exit $failed 41 | -------------------------------------------------------------------------------- /tests/runtests-scripts.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -x 3 | WISP="${1}" 4 | BUILDDIR="${2}" 5 | SRCDIR="${3}" 6 | 7 | function die () { 8 | echo $1 9 | exit 1 10 | } 11 | 12 | ${WISP} -L "${SRCDIR}" -C "${BUILDDIR}" -c 'display 1' | grep -q 1 || die 'failed to display output' 13 | -------------------------------------------------------------------------------- /tests/self-referencial.scm: -------------------------------------------------------------------------------- 1 | ; http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro 2 | ; because this is as cool as things get 3 | (define-syntax slambda 4 | (lambda (x) 5 | (syntax-case x () 6 | ((slambda formals body0 body1 ...) 7 | (with-syntax 8 | ((self (datum->syntax #'slambda 'self))) 9 | #'(letrec ((self (lambda formals body0 body1 ...))) 10 | self)))))) 11 | 12 | 13 | 14 | ( 15 | (slambda (x) (+ x 1)) 16 | 10) 17 | 18 | ((slambda () self)) 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /tests/self-referencial.w: -------------------------------------------------------------------------------- 1 | ; http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro 2 | ; because this is as cool as things get 3 | define-syntax slambda 4 | lambda : x 5 | syntax-case x : 6 | : slambda formals body0 body1 ... 7 | with-syntax 8 | : self : datum->syntax #'slambda 'self 9 | #' letrec : : self : lambda formals body0 body1 ... 10 | . self 11 | 12 | 13 | 14 | : 15 | slambda (x) : + x 1 16 | . 10 17 | 18 | : slambda () self 19 | 20 | -------------------------------------------------------------------------------- /tests/shebang.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/wisp.py # !# 2 | ; This tests shebang lines 3 | 4 | 5 | -------------------------------------------------------------------------------- /tests/shebang.w: -------------------------------------------------------------------------------- 1 | #!/usr/bin/wisp.py # !# 2 | ; This tests shebang lines 3 | -------------------------------------------------------------------------------- /tests/strangecomments.scm: -------------------------------------------------------------------------------- 1 | (use-modules (wisp-scheme)) 2 | ; works 3 | (display 4 | (call-with-input-string "foo ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n foo : moo \"\n\" \n___ . goo . hoo" wisp-scheme-read-chunk)) 5 | (newline) 6 | (display 7 | (call-with-input-string "foo \n___ . goo . hoo" wisp-scheme-read-chunk)) 8 | (newline) 9 | 10 | ; broken 11 | ; expected: 12 | (display 13 | (call-with-input-string "(foo) ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n foo : moo \"\n\" \n___ . [goo . hoo]" wisp-scheme-read-chunk)) 14 | (newline) 15 | (display 16 | (call-with-input-string "foo \n___ . [goo . hoo]" wisp-scheme-read-chunk)) 17 | (newline) 18 | 19 | -------------------------------------------------------------------------------- /tests/strangecomments.w: -------------------------------------------------------------------------------- 1 | use-modules : wisp-scheme 2 | ; works 3 | display 4 | call-with-input-string "foo ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n foo : moo \"\n\" \n___ . goo . hoo" wisp-scheme-read-chunk 5 | newline 6 | display 7 | call-with-input-string "foo \n___ . goo . hoo" wisp-scheme-read-chunk 8 | newline 9 | 10 | ; broken 11 | ; expected: 12 | display 13 | call-with-input-string "(foo) ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n foo : moo \"\n\" \n___ . [goo . hoo]" wisp-scheme-read-chunk 14 | newline 15 | display 16 | call-with-input-string "foo \n___ . [goo . hoo]" wisp-scheme-read-chunk 17 | newline 18 | -------------------------------------------------------------------------------- /tests/sublist.scm: -------------------------------------------------------------------------------- 1 | ; sublists allow to start single line function calls with a colon ( : ). 2 | 3 | (defun a (b c) 4 | (let ((e . f)) 5 | g)) 6 | 7 | 8 | -------------------------------------------------------------------------------- /tests/sublist.w: -------------------------------------------------------------------------------- 1 | ; sublists allow to start single line function calls with a colon ( : ). 2 | ; 3 | defun a : b c 4 | let : : e . f 5 | . g 6 | -------------------------------------------------------------------------------- /tests/sxml.scm: -------------------------------------------------------------------------------- 1 | (use-modules (sxml simple)) 2 | (use-modules (ice-9 match)) 3 | 4 | ; define a template 5 | (define template 6 | (quote 7 | (html 8 | (head (title "test")) 9 | (body 10 | (h1 "test") 11 | (message "the header") 12 | (p "it " (em "works!") 13 | (br) 14 | (" it actually works!")))))) 15 | 16 | ; transform it 17 | (define template2 18 | (let loop 19 | ((l template)) 20 | (match l 21 | (('message a ...) 22 | `(p (@ (style "margin-left: 2em")) 23 | (strong ,(map loop a)))) 24 | ((a ...) 25 | (map loop a )) 26 | (a 27 | a)))) 28 | 29 | ; write xml to the output port 30 | (sxml->xml template2) 31 | 32 | (newline) 33 | 34 | 35 | -------------------------------------------------------------------------------- /tests/sxml.w: -------------------------------------------------------------------------------- 1 | use-modules : sxml simple 2 | use-modules : ice-9 match 3 | 4 | ; define a template 5 | define template 6 | quote 7 | html 8 | head : title "test" 9 | body 10 | h1 "test" 11 | message "the header" 12 | p "it " : em "works!" 13 | br 14 | " it actually works!" 15 | 16 | ; transform it 17 | define template2 18 | let loop 19 | : l template 20 | match l 21 | : 'message a ... 22 | ` p : @ : style "margin-left: 2em" 23 | strong ,(map loop a) 24 | : a ... 25 | map loop a 26 | a 27 | . a 28 | 29 | ; write xml to the output port 30 | sxml->xml template2 31 | 32 | newline 33 | -------------------------------------------------------------------------------- /tests/syntax-colon.scm: -------------------------------------------------------------------------------- 1 | (let 2 | ( 3 | (a 1) 4 | (b 2)) 5 | (let 6 | ( 7 | ( 8 | c 3)) 9 | (format #t "a: ~A, b: ~A, c: ~A" 10 | a b c))) 11 | 12 | ((a)) 13 | 14 | (define (hello) 15 | (display "hello\n")) 16 | 17 | (let 18 | ((a 1) 19 | (b 2)) 20 | (format #t "a: ~A, b: ~A" 21 | a b)) 22 | 23 | (let ((a '()))) 24 | 25 | (let 26 | ( ; foo 27 | (a 28 | '()))) 29 | 30 | ( 31 | (a)) 32 | 33 | (define (:) 34 | (hello)) 35 | 36 | (:) 37 | 38 | 39 | -------------------------------------------------------------------------------- /tests/syntax-colon.w: -------------------------------------------------------------------------------- 1 | let 2 | : 3 | a 1 4 | b 2 5 | let 6 | : 7 | : 8 | . c 3 9 | format #t "a: ~A, b: ~A, c: ~A" 10 | . a b c 11 | 12 | : a 13 | 14 | define : hello 15 | display "hello\n" 16 | 17 | let 18 | : a 1 19 | b 2 20 | format #t "a: ~A, b: ~A" 21 | . a b 22 | 23 | let : : a ' : 24 | 25 | let 26 | : ; foo 27 | a 28 | ' 29 | 30 | : 31 | a 32 | 33 | define : \: 34 | hello 35 | 36 | \: 37 | -------------------------------------------------------------------------------- /tests/syntax-dot.scm: -------------------------------------------------------------------------------- 1 | (define (foo) 2 | "bar") 3 | 4 | (define (bar) 5 | '(1 6 | . 2 )); pair 7 | 8 | (display (foo)) 9 | (newline) 10 | (display (bar)) 11 | (newline) 12 | 13 | 14 | -------------------------------------------------------------------------------- /tests/syntax-dot.w: -------------------------------------------------------------------------------- 1 | define : foo 2 | . "bar" 3 | 4 | define : bar 5 | ' 1 6 | . . 2 ; pair 7 | 8 | display : foo 9 | newline 10 | display : bar 11 | newline 12 | -------------------------------------------------------------------------------- /tests/syntax-empty.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/tests/syntax-empty.scm -------------------------------------------------------------------------------- /tests/syntax-empty.w: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/emacsmirror/wisp-mode/33e4df4524a945aeafb48c93d4df7fa98a4ecace/tests/syntax-empty.w -------------------------------------------------------------------------------- /tests/syntax-indent.scm: -------------------------------------------------------------------------------- 1 | (define 2 | (hello who) 3 | (format #t "Hello ~A\n" who)) 4 | 5 | (define 6 | (let 7 | ( 8 | (a 1) 9 | (b 2) 10 | (c 3)) 11 | (format #t "a: ~A, b: ~A, c: ~A" 12 | (+ a 2) 13 | b c))) 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /tests/syntax-indent.w: -------------------------------------------------------------------------------- 1 | define 2 | hello who 3 | format #t "Hello ~A\n" who 4 | 5 | define 6 | let 7 | : 8 | a 1 9 | b 2 10 | c 3 11 | format #t "a: ~A, b: ~A, c: ~A" 12 | + a 2 13 | . b c 14 | 15 | -------------------------------------------------------------------------------- /tests/syntax-strings-parens.scm: -------------------------------------------------------------------------------- 1 | ; Test linebreaks in strings and brackets 2 | 3 | "flubbub 4 | 5 | flabbab" 6 | 7 | (hrug (nadda 8 | madda gadda "shoktom 9 | mee" " sep 10 | ka" 11 | hadda) 12 | (gom)) 13 | 14 | (flu) 15 | 16 | (sum [foo 17 | bar] barz {1 + [* 2 2]}) 18 | 19 | (mara { 20 | li 21 | + 22 | lo - (mabba) 23 | }) 24 | -------------------------------------------------------------------------------- /tests/syntax-strings-parens.w: -------------------------------------------------------------------------------- 1 | ; Test linebreaks in strings and brackets 2 | 3 | . "flubbub 4 | 5 | flabbab" 6 | 7 | hrug (nadda 8 | madda gadda "shoktom 9 | mee" " sep 10 | ka" 11 | hadda) 12 | gom 13 | 14 | flu 15 | 16 | sum [foo 17 | bar] barz {1 + [* 2 2]} 18 | 19 | mara { 20 | li 21 | + 22 | lo - (mabba) 23 | } 24 | -------------------------------------------------------------------------------- /tests/syntax-underscore.scm: -------------------------------------------------------------------------------- 1 | (define (a b c) 2 | (d e 3 | (f) 4 | (g h) 5 | i)) 6 | 7 | (define (_) 8 | (display "hello\n")) 9 | 10 | (_) 11 | 12 | 13 | -------------------------------------------------------------------------------- /tests/syntax-underscore.w: -------------------------------------------------------------------------------- 1 | define : a b c 2 | _ d e 3 | ___ f 4 | ___ g h 5 | __ . i 6 | 7 | define : _ 8 | _ display "hello\n" 9 | 10 | \_ 11 | -------------------------------------------------------------------------------- /wisp-reader.w: -------------------------------------------------------------------------------- 1 | ;; Language interface for Wisp in Guile 2 | ;; 3 | ;;; -Author: Arne Babenhauserheide 4 | 5 | ;;; adapted from guile-sweet: https://gitorious.org/nacre/guile-sweet/source/ae306867e371cb4b56e00bb60a50d9a0b8353109:sweet/common.scm 6 | 7 | ;;; Copyright (C) 2005--2014 by David A. Wheeler and Alan Manuel K. Gloria 8 | ;;; Copyright (C) 2014--2023 Arne Babenhauserheide. 9 | ;;; Copyright (C) 2023 Maxime Devos 10 | 11 | ;;; Permission is hereby granted, free of charge, to any person 12 | ;;; obtaining a copy of this software and associated documentation 13 | ;;; files (the "Software"), to deal in the Software without 14 | ;;; restriction, including without limitation the rights to use, copy, 15 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 16 | ;;; of the Software, and to permit persons to whom the Software is 17 | ;;; furnished to do so, subject to the following conditions: 18 | ;;; 19 | ;;; The above copyright notice and this permission notice shall be 20 | ;;; included in all copies or substantial portions of the Software. 21 | ;;; 22 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 23 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 24 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 25 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 26 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 27 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 28 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 29 | ;;; SOFTWARE. 30 | 31 | ; adapted from spec.scm: https://gitorious.org/nacre/guile-sweet/source/ae306867e371cb4b56e00bb60a50d9a0b8353109:sweet/spec.scm 32 | define-module : language wisp spec 33 | ; . #:use-module : wisp 34 | . #:use-module : language wisp 35 | . #:use-module : system base compile 36 | . #:use-module : system base language 37 | . #:use-module : language scheme compile-tree-il 38 | . #:use-module : language scheme decompile-tree-il 39 | . #:export : wisp 40 | 41 | ;;; 42 | ;;; Language definition 43 | ;;; 44 | 45 | define : read-one-wisp-sexp port env 46 | ;; Allow using "# foo" as #(foo). 47 | ;; Don't use the globally-acting read-hash-extend, because this 48 | ;; doesn't make much sense in parenthese-y (non-Wisp) Scheme. 49 | ;; Instead, use fluids to temporarily add the extension. 50 | with-fluids : : %read-hash-procedures : fluid-ref %read-hash-procedures 51 | read-hash-extend #\# : lambda args #\# 52 | ;; Read Wisp files as UTF-8, to support non-ASCII characters. 53 | ;; TODO: would be nice to support ';; coding: whatever' lines 54 | ;; like in parenthese-y Scheme. 55 | set-port-encoding! port "UTF-8" 56 | if : eof-object? : peek-char port 57 | read-char port ; return eof: we’re done 58 | let : : chunk : wisp-scheme-read-chunk port 59 | and : not : null? chunk ; <---- XXX: maybe (pair? chunk) 60 | car chunk 61 | 62 | define-language wisp 63 | . #:title "Wisp Scheme Syntax. See SRFI-119 for details. THIS IS EXPERIMENTAL, USE AT YOUR OWN RISK" 64 | ; . #:reader read-one-wisp-sexp 65 | . #:reader read-one-wisp-sexp ; : lambda (port env) : let ((x (read-one-wisp-sexp port env))) (display x)(newline) x ; 66 | . #:compilers `((tree-il . ,compile-tree-il)) 67 | . #:decompilers `((tree-il . ,decompile-tree-il)) 68 | . #:evaluator : lambda (x module) : primitive-eval x 69 | . #:printer write ; TODO: backtransform to wisp? Use source-properties? 70 | . #:make-default-environment 71 | lambda : 72 | ;; Ideally we'd duplicate the whole module hierarchy so that `set!', 73 | ;; `fluid-set!', etc. don't have any effect in the current environment. 74 | let : : m : make-fresh-user-module 75 | ;; Provide a separate `current-reader' fluid so that 76 | ;; compile-time changes to `current-reader' are 77 | ;; limited to the current compilation unit. 78 | module-define! m 'current-reader : make-fluid 79 | ;; Default to `simple-format', as is the case until 80 | ;; (ice-9 format) is loaded. This allows 81 | ;; compile-time warnings to be emitted when using 82 | ;; unsupported options. 83 | module-set! m 'format simple-format 84 | . m 85 | 86 | -------------------------------------------------------------------------------- /wisp-repl-guile.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # if the spec file does not exist yet, run the build chain 4 | if test ! -f language/wisp/spec.scm; then 5 | # if we are in a distribution tarball, just run configure 6 | if test -f ./configure; then 7 | ./configure && make check 8 | # otherwise run the full autoconf chain 9 | else 10 | autoreconf -i && ./configure && make check 11 | fi 12 | fi 13 | 14 | # if the file still does not exist, our chain is broken 15 | if test ! -f language/wisp/spec.scm; then 16 | echo "ERROR: wisp failed to compile. Please check the previous output." 17 | else 18 | guile -L . --language=wisp 19 | fi 20 | -------------------------------------------------------------------------------- /wisp.in: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # -*- wisp -*- 3 | # set Guile if unset 4 | if [ -z ${GUILE+x} ]; then 5 | GUILE=guile 6 | fi 7 | # ensure that wisp is compiled 8 | "${GUILE}" -c '(import (language wisp))' >/dev/null 2>&1 9 | exec -a "$0" "${GUILE}" -x .w --language=wisp "$@" 10 | --------------------------------------------------------------------------------