├── .gitattributes ├── .gitignore ├── .travis.yml ├── AUTHORS ├── LICENSE ├── Makefile ├── README.md ├── contrib ├── 10.attribute │ ├── attr.scm │ └── nitro.mk ├── 10.macro │ ├── macro.scm │ ├── nitro.mk │ └── t │ │ └── ir-macro.scm ├── 10.math │ ├── math.c │ └── nitro.mk ├── 10.roundtrip │ ├── emyg_atod.c │ ├── emyg_atod.h │ ├── emyg_dtoa.c │ ├── emyg_dtoa.h │ ├── emyg_pow5.h │ ├── nitro.mk │ └── t │ │ └── roundtrip.scm ├── 20.r7rs │ ├── docs │ │ └── doc.rst │ ├── nitro.mk │ ├── scheme │ │ ├── base.scm │ │ ├── case-lambda.scm │ │ ├── cxr.scm │ │ ├── eval.scm │ │ ├── file.scm │ │ ├── inexact.scm │ │ ├── lazy.scm │ │ ├── load.scm │ │ ├── process-context.scm │ │ ├── r5rs.scm │ │ ├── read.scm │ │ ├── time.scm │ │ └── write.scm │ ├── src │ │ ├── file.c │ │ ├── load.c │ │ ├── r7rs.c │ │ ├── system.c │ │ └── time.c │ └── t │ │ ├── r7rs.scm │ │ └── syntax-rules.scm ├── 30.optional │ ├── nitro.mk │ ├── piclib │ │ └── optional.scm │ └── t │ │ └── test.scm ├── 30.partcont │ ├── docs │ │ └── doc.rst │ ├── nitro.mk │ └── piclib │ │ └── partcont.scm ├── 30.pretty-print │ ├── docs │ │ └── doc.rst │ ├── nitro.mk │ └── pretty-print.scm ├── 30.random │ ├── nitro.mk │ ├── src │ │ ├── mt19937ar.c │ │ └── random.c │ └── t │ │ └── test.scm ├── 30.readline │ ├── example │ │ └── simple-repl.scm │ ├── nitro.mk │ ├── src │ │ └── readline.c │ └── t │ │ └── test.scm ├── 30.regexp │ ├── docs │ │ └── doc.rst │ ├── nitro.mk │ ├── src │ │ └── regexp.c │ └── t │ │ └── test.scm ├── 30.test │ ├── nitro.mk │ └── test.scm ├── 40.procedure │ ├── nitro.mk │ └── procedure.scm ├── 40.srfi │ ├── docs │ │ └── doc.rst │ ├── examples │ │ └── 106 │ │ │ ├── simple-echo-client.scm │ │ │ └── simple-echo-server.scm │ ├── nitro.mk │ ├── src │ │ ├── 0.c │ │ └── 106.c │ ├── srfi │ │ ├── 0.scm │ │ ├── 1.scm │ │ ├── 106.scm │ │ ├── 111.scm │ │ ├── 17.scm │ │ ├── 26.scm │ │ ├── 43.scm │ │ ├── 60.scm │ │ ├── 8.scm │ │ └── 95.scm │ └── t │ │ ├── 1.scm │ │ └── 106.scm ├── 50.class │ ├── nitro.mk │ └── piclib │ │ └── picrin │ │ └── class.scm ├── 50.destructuring-bind │ ├── lambda.scm │ └── nitro.mk ├── 50.for │ ├── docs │ │ └── doc.rst │ ├── nitro.mk │ ├── piclib │ │ └── for.scm │ └── t │ │ └── test.scm ├── 50.option │ ├── nitro.mk │ ├── option.scm │ └── t │ │ └── test.scm ├── 60.logic │ ├── logic.scm │ ├── nitro.mk │ └── t │ │ └── logic-test.scm ├── 60.peg │ ├── TODO │ ├── nitro.mk │ ├── picrin │ │ ├── parser.scm │ │ └── parser │ │ │ └── string.scm │ └── t │ │ └── peg.scm ├── 60.repl │ ├── nitro.mk │ ├── repl.c │ └── repl.scm ├── 70.main │ ├── main.scm │ └── nitro.mk ├── 80.protocol │ ├── nitro.mk │ └── piclib │ │ └── picrin │ │ └── protocol.scm └── 90.array │ ├── array.scm │ ├── nitro.mk │ └── t │ └── array.scm ├── docs ├── Makefile ├── capi.rst ├── conf.py ├── deploy.rst ├── index.rst ├── intro.rst ├── lang.rst ├── libs.rst └── make.bat ├── etc ├── LIBRARY_IMPL.md ├── R7RS │ ├── .gitignore │ ├── COPYRIGHT │ ├── README │ ├── bench │ ├── inputs │ │ ├── NormalizationTest.txt │ │ ├── ack.input │ │ ├── array1.input │ │ ├── bib │ │ ├── bib16 │ │ ├── bibfreq.input │ │ ├── bibfreq2.input │ │ ├── browse.input │ │ ├── bv2string.input │ │ ├── cat.input │ │ ├── cat2.input │ │ ├── cat3.input │ │ ├── compiler.input │ │ ├── conform.input │ │ ├── cpstak.input │ │ ├── ctak.input │ │ ├── dderiv.input │ │ ├── deriv.input │ │ ├── destruc.input │ │ ├── diviter.input │ │ ├── divrec.input │ │ ├── dynamic.data │ │ ├── dynamic.input │ │ ├── earley.input │ │ ├── equal.input │ │ ├── fft.input │ │ ├── fib.input │ │ ├── fibc.input │ │ ├── fibfp.input │ │ ├── gcbench.input │ │ ├── graphs.input │ │ ├── hashtable0.input │ │ ├── lattice.input │ │ ├── listsort.input │ │ ├── matrix.input │ │ ├── maze.input │ │ ├── mazefun.input │ │ ├── mbrot.input │ │ ├── mbrotZ.input │ │ ├── mperm.input │ │ ├── nboyer.input │ │ ├── normalization.input │ │ ├── nqueens.input │ │ ├── ntakl.input │ │ ├── nucleic.input │ │ ├── paraffins.input │ │ ├── parsing.data │ │ ├── parsing.input │ │ ├── parsing16.data │ │ ├── peval.input │ │ ├── pi.input │ │ ├── pnpoly.input │ │ ├── primes.input │ │ ├── puzzle.input │ │ ├── quicksort.input │ │ ├── ray.input │ │ ├── read0.input │ │ ├── read1.input │ │ ├── read2.input │ │ ├── read3.input │ │ ├── sboyer.input │ │ ├── scheme.input │ │ ├── simplex.input │ │ ├── slatex-data │ │ │ ├── slatex.sty │ │ │ └── test.tex │ │ ├── slatex.input │ │ ├── string.input │ │ ├── sum.input │ │ ├── sum1.data │ │ ├── sum1.input │ │ ├── sumfp.input │ │ ├── tail.input │ │ ├── tak.input │ │ ├── takl.input │ │ ├── triangl.input │ │ ├── vecsort.input │ │ └── wc.input │ └── src │ │ ├── ack.sch │ │ ├── array1.sch │ │ ├── bibfreq.sch │ │ ├── bibfreq2.sch │ │ ├── browse.sch │ │ ├── bv2string.sch │ │ ├── cat.sch │ │ ├── cat2.sch │ │ ├── cat3.sch │ │ ├── common.sch │ │ ├── compiler.sch │ │ ├── conform.sch │ │ ├── cpstak.sch │ │ ├── ctak.sch │ │ ├── dderiv.sch │ │ ├── deriv.sch │ │ ├── destruc.sch │ │ ├── diviter.sch │ │ ├── divrec.sch │ │ ├── dynamic.sch │ │ ├── earley.sch │ │ ├── equal.sch │ │ ├── fft.sch │ │ ├── fib.sch │ │ ├── fibc.sch │ │ ├── fibfp.sch │ │ ├── gcbench.sch │ │ ├── graphs.sch │ │ ├── hashtable0.sch │ │ ├── lattice.sch │ │ ├── listsort.sch │ │ ├── matrix.sch │ │ ├── maze.sch │ │ ├── mazefun.sch │ │ ├── mbrot.sch │ │ ├── mbrotZ.sch │ │ ├── mperm.sch │ │ ├── nboyer.sch │ │ ├── normalization.sch │ │ ├── nqueens.sch │ │ ├── ntakl.sch │ │ ├── nucleic.sch │ │ ├── paraffins.sch │ │ ├── parsing.sch │ │ ├── peval.sch │ │ ├── pi.sch │ │ ├── pnpoly.sch │ │ ├── primes.sch │ │ ├── puzzle.sch │ │ ├── quicksort.sch │ │ ├── ray.sch │ │ ├── read0.sch │ │ ├── read1.sch │ │ ├── read2.sch │ │ ├── read3.sch │ │ ├── sboyer.sch │ │ ├── scheme.sch │ │ ├── simplex.sch │ │ ├── slatex.sch │ │ ├── string.sch │ │ ├── sum.sch │ │ ├── sum1.sch │ │ ├── sumfp.sch │ │ ├── tail.sch │ │ ├── tak.sch │ │ ├── takl.sch │ │ ├── triangl.sch │ │ ├── vecsort.sch │ │ └── wc.sch ├── build.sh ├── libc_polyfill.c ├── picrin-c-keyword-highlight.el ├── picrin-logo-fin01-01.png ├── picrin-logo-fin01-02.png ├── picrin-scheme-keyword-highlight.el ├── srfi.txt └── tak.scm ├── lib ├── README.md ├── blob.c ├── bool.c ├── char.c ├── cont.c ├── data.c ├── debug.c ├── dict.c ├── error.c ├── ext │ ├── boot.c │ ├── eval.c │ ├── lib.c │ ├── load.c │ ├── read.c │ └── write.c ├── gc.c ├── include │ ├── picconf.h │ ├── picrin.h │ └── picrin │ │ ├── extra.h │ │ ├── setup.h │ │ └── value.h ├── khash.h ├── number.c ├── object.h ├── pair.c ├── port.c ├── proc.c ├── record.c ├── state.c ├── state.h ├── string.c ├── symbol.c ├── var.c ├── vector.c ├── vm.h └── weak.c ├── piclib ├── boot.scm └── library.scm ├── src ├── main.c └── tiny-main.c ├── t ├── byteio.scm ├── closure.scm ├── dynamic-wind.scm ├── escape.scm ├── exception.scm ├── hello.scm ├── issue │ ├── 234.scm │ ├── 250.scm │ ├── 257.scm │ ├── 282.scm │ ├── 308.sh │ ├── 312.scm │ ├── 322.scm │ ├── foo-map.scm │ ├── parameterize.scm │ ├── pic_call.scm │ └── string-copy.scm ├── letrec.scm ├── override.scm ├── parameterize.scm ├── renaming-import.scm ├── shebang.scm ├── tail-call.scm └── tailcall.scm └── tools ├── mkboot.pl ├── mkinit.pl └── mkloader.pl /.gitattributes: -------------------------------------------------------------------------------- 1 | *.sch linguist-language=Scheme 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | src/load_piclib.c 3 | src/init_contrib.c 4 | docs/contrib.rst 5 | .dir-locals.el 6 | GPATH 7 | GRTAGS 8 | GTAGS 9 | _build 10 | _static 11 | _template 12 | .DS_Store 13 | picrin 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | compiler: 4 | - gcc 5 | - clang 6 | addons: 7 | apt: 8 | packages: 9 | - gcc-multilib 10 | # - valgrind 11 | env: 12 | - CFLAGS="-m32" 13 | - CFLAGS="-m64" 14 | script: 15 | - perl --version 16 | - make 17 | - make test 18 | # - make test-contrib TEST_RUNNER="valgrind -q --leak-check=full --dsymutil=yes --error-exitcode=1 bin/picrin" 19 | - make clean 20 | - make debug 21 | - make test 22 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Yuichi Nishiwaki (yuichi.nishiwaki@gmail.com) 2 | Masanori Ogino (masanori.ogino@gmail.com) 3 | Yuito Murase (themamedaifuku@gmail.com) 4 | Hiromu Yakura (hiromu1996@gmail.com) 5 | Wataru Nakanishi (stibear1996@gmail.com) 6 | Hiroki Kobayashi (silentkiddie-2013@yahoo.co.jp) 7 | Sunrin SHIMURA (3han5chou7@gmail.com) 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # The project is in hiatus and being archived soon... 4 | 5 | [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin) 6 | [![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/) 7 | 8 | Picrin is a lightweight R7RS scheme implementation written in pure C89. It contains a reasonably fast VM, an improved hygienic macro system, useful contribution libraries, and simple but powerful C interface. 9 | 10 | - R7RS compatible 11 | - Reentrant design (all VM states are stored in single global state object) 12 | - Bytecode interpreter 13 | - Direct threaded VM 14 | - Internal representation by nan-boxing (available only on x64) 15 | - Conservative call/cc implementation (VM stack and native c stack can interleave) 16 | - Exact GC (simple mark and sweep, partially reference count) 17 | - String representation by rope 18 | - Hygienic macro transformers (syntactic closures, explicit and implicit renaming macros) 19 | - Extended library syntax 20 | 21 | ## Documentation 22 | 23 | See http://picrin.readthedocs.org/ 24 | 25 | ## Homepage 26 | 27 | Currently picrin is hosted on Github. You can freely send a bug report or pull-request, and fork the repository. 28 | 29 | https://github.com/picrin-scheme/picrin 30 | 31 | ## Build 32 | 33 | Just type `make` in the project root directory. You will find an executable binary newly created at bin/ directory. 34 | 35 | $ make 36 | 37 | When you are building picrin on x86_64 system, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail). 38 | 39 | ## Install 40 | 41 | `make install` target is provided. By default it installs picrin binary into `/usr/local/bin/`. 42 | 43 | $ make install 44 | 45 | Since picrin does not use autoconf, if you want to specify the install directory, pass the custom path to `make` via command line argument. 46 | 47 | $ make install prefix=/path/to/dir 48 | 49 | ## Requirement 50 | 51 | To build Picrin Scheme from source code, some external libraries are required: 52 | 53 | - perl 54 | - regex.h of POSIX.1 55 | - libedit (optional) 56 | 57 | Make command automatically turns on optional libraries if available. 58 | Picrin is mainly developed on Mac OS X and only tested on OS X or Ubuntu 14.04+. When you tried to run picrin on other platforms and found something was wrong with it, please send us an issue. 59 | 60 | ## Authors 61 | 62 | See `AUTHORS` 63 | -------------------------------------------------------------------------------- /contrib/10.attribute/attr.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin base) 2 | 3 | (define attribute-table (make-ephemeron-table)) 4 | 5 | (define (attribute obj) 6 | (let ((r (attribute-table obj))) 7 | (if r 8 | (cdr r) 9 | (let ((dict (make-dictionary))) 10 | (attribute-table obj dict) 11 | dict)))) 12 | 13 | (export attribute)) 14 | -------------------------------------------------------------------------------- /contrib/10.attribute/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += \ 2 | contrib/10.attribute/attr.scm 3 | -------------------------------------------------------------------------------- /contrib/10.macro/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/10.macro/*.scm) 2 | 3 | CONTRIB_TESTS += test-macro 4 | 5 | test-macro: $(TEST_RUNNER) 6 | ./$(TEST_RUNNER) contrib/10.macro/t/ir-macro.scm 7 | -------------------------------------------------------------------------------- /contrib/10.macro/t/ir-macro.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin macro) 3 | (picrin test)) 4 | 5 | (test-begin) 6 | 7 | (define-macro aif 8 | (ir-macro-transformer 9 | (lambda (form inject cmp) 10 | (let ((it (inject 'it)) 11 | (expr (car (cdr form))) 12 | (then (car (cdr (cdr form)))) 13 | (else (car (cdr (cdr (cdr form)))))) 14 | `(let ((,it ,expr)) 15 | (if ,it ,then ,else)))))) 16 | 17 | (test 'b 18 | (aif (member 'b '(a b c)) (car it) #f)) 19 | 20 | ;;; test hygiene begin 21 | 22 | (define-macro mif 23 | (ir-macro-transformer 24 | (lambda (form inject cmp) 25 | (let ((expr (car (cdr form))) 26 | (then (car (cdr (cdr form)))) 27 | (else (car (cdr (cdr (cdr form)))))) 28 | `(let ((it ,expr)) 29 | (if it ,then ,else)))))) 30 | 31 | (test 2 32 | (let ((if 42)) 33 | (mif 1 2 3))) 34 | ; => 2 35 | 36 | (test 42 37 | (let ((it 42)) 38 | (mif 1 it 2))) 39 | ; => 42 40 | 41 | ;;; end 42 | 43 | 44 | 45 | ;;; test core syntax begin 46 | 47 | (test 'b (mif 'a 'b 'c)) 48 | ; => b 49 | 50 | (define-macro loop 51 | (ir-macro-transformer 52 | (lambda (expr inject cmp) 53 | (let ((body (cdr expr))) 54 | `(call-with-current-continuation 55 | (lambda (,(inject 'exit)) 56 | (let f () 57 | ,@body (f)))))))) 58 | 59 | (define a 1) 60 | (test #f 61 | (loop 62 | (if (= a 2) (exit #f)) 63 | (set! a 2))) 64 | ; => #f 65 | 66 | (test #f 67 | (loop 68 | (define a 1) 69 | (if (= a 1) (exit #f)))) 70 | ; => #f 71 | 72 | (test-end) 73 | -------------------------------------------------------------------------------- /contrib/10.math/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_INITS += math 2 | 3 | CONTRIB_SRCS += contrib/10.math/math.c 4 | -------------------------------------------------------------------------------- /contrib/10.roundtrip/emyg_atod.h: -------------------------------------------------------------------------------- 1 | /* emyg_atod.h */ 2 | 3 | 4 | #ifdef __cplusplus 5 | extern "C" { 6 | #endif 7 | 8 | double emyg_strtod (const char *nptr, char **endptr); 9 | 10 | double emyg_atod (const char *nptr); 11 | 12 | #ifdef __cplusplus 13 | } 14 | #endif 15 | -------------------------------------------------------------------------------- /contrib/10.roundtrip/emyg_dtoa.h: -------------------------------------------------------------------------------- 1 | /* emyg_dtoa.h */ 2 | 3 | #ifdef __cplusplus 4 | extern "C" { 5 | #endif 6 | 7 | void emyg_dtoa (double value, char *buffer); 8 | 9 | #ifdef __cplusplus 10 | } 11 | #endif 12 | 13 | -------------------------------------------------------------------------------- /contrib/10.roundtrip/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_DEFS += -DPIC_CSTRING_TO_DOUBLE=emyg_atod -DPIC_DOUBLE_TO_CSTRING=emyg_dtoa 2 | 3 | CONTRIB_SRCS += contrib/10.roundtrip/emyg_dtoa.c \ 4 | contrib/10.roundtrip/emyg_atod.c 5 | 6 | CONTRIB_TESTS += test-roundtrip 7 | 8 | test-roundtrip: $(TEST_RUNNER) 9 | ./$(TEST_RUNNER) contrib/10.roundtrip/t/roundtrip.scm 10 | -------------------------------------------------------------------------------- /contrib/10.roundtrip/t/roundtrip.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (srfi 27) 3 | (scheme inexact) 4 | (picrin test)) 5 | 6 | (test-begin) 7 | 8 | (define (rountrip-ok number) 9 | (let ((radix 10)) 10 | (eqv? number (string->number (number->string number radix) radix)))) 11 | 12 | (test #t (rountrip-ok -nan.0)) 13 | 14 | (test #t (rountrip-ok +nan.0)) 15 | 16 | (test #t (rountrip-ok -inf.0)) 17 | 18 | (test #t (rountrip-ok +inf.0)) 19 | 20 | (test #t (rountrip-ok +0.0)) 21 | 22 | (test #t (rountrip-ok -0.0)) 23 | 24 | (test #t (rountrip-ok 0.0)) 25 | 26 | (test -inf.0 (string->number "-inf.0")) 27 | 28 | (test +inf.0 (string->number "+inf.0")) 29 | 30 | (test #t (nan? (string->number "-nan.0"))) 31 | 32 | (test #t (nan? (string->number "+nan.0"))) 33 | 34 | (define (random-roundtrip) 35 | (let ((r (random-real))) 36 | (if (rountrip-ok r) 37 | #t 38 | r))) 39 | 40 | (test #t (random-roundtrip)) 41 | (test #t (random-roundtrip)) 42 | (test #t (random-roundtrip)) 43 | (test #t (random-roundtrip)) 44 | (test #t (random-roundtrip)) 45 | (test #t (random-roundtrip)) 46 | (test #t (random-roundtrip)) 47 | (test #t (random-roundtrip)) 48 | (test #t (random-roundtrip)) 49 | (test #t (random-roundtrip)) 50 | (test #t (random-roundtrip)) 51 | (test #t (random-roundtrip)) 52 | (test #t (random-roundtrip)) 53 | 54 | (test-end) 55 | -------------------------------------------------------------------------------- /contrib/20.r7rs/docs/doc.rst: -------------------------------------------------------------------------------- 1 | Scheme standard libraries 2 | ------------------------- 3 | 4 | - (scheme write) 5 | - (scheme cxr) 6 | - (scheme file) 7 | - (scheme inexact) 8 | - (scheme time) 9 | - (scheme process-context) 10 | - (scheme load) 11 | - (scheme lazy) 12 | 13 | -------------------------------------------------------------------------------- /contrib/20.r7rs/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_INITS += r7rs 2 | 3 | CONTRIB_SRCS += \ 4 | contrib/20.r7rs/src/r7rs.c\ 5 | contrib/20.r7rs/src/file.c\ 6 | contrib/20.r7rs/src/load.c\ 7 | contrib/20.r7rs/src/system.c\ 8 | contrib/20.r7rs/src/time.c 9 | 10 | CONTRIB_LIBS += \ 11 | contrib/20.r7rs/scheme/base.scm\ 12 | contrib/20.r7rs/scheme/cxr.scm\ 13 | contrib/20.r7rs/scheme/read.scm\ 14 | contrib/20.r7rs/scheme/write.scm\ 15 | contrib/20.r7rs/scheme/file.scm\ 16 | contrib/20.r7rs/scheme/case-lambda.scm\ 17 | contrib/20.r7rs/scheme/lazy.scm\ 18 | contrib/20.r7rs/scheme/eval.scm\ 19 | contrib/20.r7rs/scheme/inexact.scm\ 20 | contrib/20.r7rs/scheme/load.scm\ 21 | contrib/20.r7rs/scheme/process-context.scm\ 22 | contrib/20.r7rs/scheme/time.scm\ 23 | contrib/20.r7rs/scheme/r5rs.scm 24 | 25 | CONTRIB_TESTS += test-r7rs 26 | 27 | test-r7rs: $(TEST_RUNNER) 28 | for test in `ls contrib/20.r7rs/t/*.scm`; do \ 29 | ./$(TEST_RUNNER) "$$test"; \ 30 | done 31 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/case-lambda.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme case-lambda) 2 | (import (scheme base)) 3 | 4 | (define (length+ list) 5 | (if (pair? list) 6 | (+ 1 (length+ (cdr list))) 7 | 0)) 8 | 9 | (define-syntax case-lambda 10 | (syntax-rules () 11 | ((case-lambda (params body0 ...) ...) 12 | (lambda args 13 | (let ((len (length args))) 14 | (letrec-syntax 15 | ((cl (syntax-rules () 16 | ((cl) 17 | (error "no matching clause")) 18 | ((cl (formal . body) . rest) 19 | (if (if (list? 'formal) 20 | (= len (length 'formal)) 21 | (>= len (length+ 'formal))) 22 | (apply (lambda formal . body) args) 23 | (cl . rest)))))) 24 | (cl (params body0 ...) ...))))))) 25 | 26 | (export case-lambda)) 27 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/cxr.scm: -------------------------------------------------------------------------------- 1 | ;;; Appendix A. Standard Libraries CxR 2 | 3 | (define-library (scheme cxr) 4 | (import (scheme base)) 5 | 6 | (define (caaar p) (car (caar p))) 7 | (define (caadr p) (car (cadr p))) 8 | (define (cadar p) (car (cdar p))) 9 | (define (caddr p) (car (cddr p))) 10 | (define (cdaar p) (cdr (caar p))) 11 | (define (cdadr p) (cdr (cadr p))) 12 | (define (cddar p) (cdr (cdar p))) 13 | (define (cdddr p) (cdr (cddr p))) 14 | (define (caaaar p) (caar (caar p))) 15 | (define (caaadr p) (caar (cadr p))) 16 | (define (caadar p) (caar (cdar p))) 17 | (define (caaddr p) (caar (cddr p))) 18 | (define (cadaar p) (cadr (caar p))) 19 | (define (cadadr p) (cadr (cadr p))) 20 | (define (caddar p) (cadr (cdar p))) 21 | (define (cadddr p) (cadr (cddr p))) 22 | (define (cdaaar p) (cdar (caar p))) 23 | (define (cdaadr p) (cdar (cadr p))) 24 | (define (cdadar p) (cdar (cdar p))) 25 | (define (cdaddr p) (cdar (cddr p))) 26 | (define (cddaar p) (cddr (caar p))) 27 | (define (cddadr p) (cddr (cadr p))) 28 | (define (cdddar p) (cddr (cdar p))) 29 | (define (cddddr p) (cddr (cddr p))) 30 | 31 | (export caaar caadr cadar caddr 32 | cdaar cdadr cddar cdddr 33 | caaaar caaadr caadar caaddr 34 | cadaar cadadr caddar cadddr 35 | cdaaar cdaadr cdadar cdaddr 36 | cddaar cddadr cdddar cddddr)) 37 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/eval.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme eval) 2 | (import (picrin base)) 3 | 4 | (define counter 0) 5 | 6 | (define-syntax (inc! n) 7 | #`(set! #,n (+ #,n 1))) 8 | 9 | (define (environment . specs) 10 | (let ((lib (string->symbol 11 | (string-append "picrin.@@my-environment." (number->string counter))))) 12 | (inc! counter) 13 | (make-library lib) 14 | (parameterize ((current-library lib)) 15 | (eval `(import ,@specs) lib)) 16 | lib)) 17 | 18 | (export environment eval)) 19 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/file.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme file) 2 | (import (picrin base) 3 | (scheme base)) 4 | 5 | (define (call-with-input-file filename callback) 6 | (call-with-port (open-input-file filename) callback)) 7 | 8 | (define (call-with-output-file filename callback) 9 | (call-with-port (open-output-file filename) callback)) 10 | 11 | (define (with-input-from-file filename thunk) 12 | (call-with-input-file filename 13 | (lambda (port) 14 | (parameterize ((current-input-port port)) 15 | (thunk))))) 16 | 17 | (define (with-output-to-file filename thunk) 18 | (call-with-output-file filename 19 | (lambda (port) 20 | (parameterize ((current-output-port port)) 21 | (thunk))))) 22 | 23 | (export open-input-file 24 | open-binary-input-file 25 | open-output-file 26 | open-binary-output-file 27 | delete-file 28 | file-exists? 29 | call-with-input-file 30 | call-with-output-file 31 | with-input-from-file 32 | with-output-to-file)) 33 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/inexact.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme inexact) 2 | (import (picrin base) 3 | (picrin math)) 4 | 5 | (export acos 6 | asin 7 | atan 8 | cos 9 | exp 10 | finite? 11 | infinite? 12 | log 13 | nan? 14 | sin 15 | sqrt 16 | tan)) 17 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/lazy.scm: -------------------------------------------------------------------------------- 1 | ;;; Appendix A. Standard Libraries Lazy 2 | 3 | (define-library (scheme lazy) 4 | (import (scheme base)) 5 | 6 | ;; type 'a = cached of 'a | chained of 'a promise | pending of () -> 'a promise 7 | 8 | (define-record-type 9 | (promise state value) 10 | promise? 11 | (state promise-state set-promise-state!) 12 | (value promise-value set-promise-value!)) 13 | 14 | (define (make-promise obj) 15 | (if (promise? obj) 16 | obj 17 | (promise 'cached obj))) 18 | 19 | (define-syntax delay-force 20 | (syntax-rules () 21 | ((_ expr) 22 | (promise (string->symbol "pending") (lambda () expr))))) 23 | 24 | (define-syntax delay 25 | (syntax-rules () 26 | ((_ expr) 27 | (delay-force (make-promise expr))))) 28 | 29 | (define (force p) 30 | (let ((v (promise-value p))) 31 | (case (promise-state p) 32 | ((cached) v) 33 | ((chained) (let () 34 | (when (eq? 'cached (promise-state v)) 35 | (set-promise-state! p 'cached) 36 | (set-promise-value! p (promise-value v))) 37 | (force v))) 38 | ((pending) (let ((q (v))) 39 | (when (eq? 'pending (promise-state p)) 40 | (set-promise-state! p 'chained) 41 | (set-promise-value! p q)) 42 | (force p)))))) 43 | 44 | (export delay-force 45 | delay 46 | force 47 | make-promise 48 | promise?)) 49 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/load.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme load) 2 | (import (picrin base)) 3 | 4 | (export load)) 5 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/process-context.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme process-context) 2 | (import (picrin base)) 3 | 4 | (export command-line 5 | emergency-exit 6 | exit 7 | get-environment-variable 8 | get-environment-variables)) 9 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/read.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme read) 2 | (import (picrin base)) 3 | 4 | (export read)) 5 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/time.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme time) 2 | (import (picrin base)) 3 | 4 | (export current-jiffy 5 | current-second 6 | jiffies-per-second)) 7 | -------------------------------------------------------------------------------- /contrib/20.r7rs/scheme/write.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme write) 2 | (import (picrin base)) 3 | 4 | (export write 5 | write-simple 6 | write-shared 7 | display)) 8 | -------------------------------------------------------------------------------- /contrib/20.r7rs/src/file.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | #include 9 | 10 | PIC_NORETURN static void 11 | file_error(pic_state *pic, const char *msg) 12 | { 13 | pic_raise(pic, pic_make_error(pic, "file", msg, pic_nil_value(pic))); 14 | } 15 | 16 | static pic_value 17 | open_file(pic_state *pic, const char *fname, const char *mode) 18 | { 19 | FILE *fp; 20 | 21 | if ((fp = fopen(fname, mode)) == NULL) { 22 | file_error(pic, "could not open file..."); 23 | } 24 | return pic_fopen(pic, fp, mode); 25 | } 26 | 27 | pic_value 28 | pic_file_open_input_file(pic_state *pic) 29 | { 30 | char *fname; 31 | 32 | pic_get_args(pic, "z", &fname); 33 | 34 | return open_file(pic, fname, "r"); 35 | } 36 | 37 | pic_value 38 | pic_file_open_output_file(pic_state *pic) 39 | { 40 | char *fname; 41 | 42 | pic_get_args(pic, "z", &fname); 43 | 44 | return open_file(pic, fname, "w"); 45 | } 46 | 47 | pic_value 48 | pic_file_exists_p(pic_state *pic) 49 | { 50 | char *fname; 51 | FILE *fp; 52 | 53 | pic_get_args(pic, "z", &fname); 54 | 55 | fp = fopen(fname, "r"); 56 | if (fp) { 57 | fclose(fp); 58 | return pic_true_value(pic); 59 | } else { 60 | return pic_false_value(pic); 61 | } 62 | } 63 | 64 | pic_value 65 | pic_file_delete(pic_state *pic) 66 | { 67 | char *fname; 68 | 69 | pic_get_args(pic, "z", &fname); 70 | 71 | if (remove(fname) != 0) { 72 | file_error(pic, "file cannot be deleted"); 73 | } 74 | return pic_undef_value(pic); 75 | } 76 | 77 | void 78 | pic_init_file(pic_state *pic) 79 | { 80 | pic_defun(pic, "scheme.base:open-input-file", pic_file_open_input_file); /* for `include' */ 81 | pic_defun(pic, "scheme.file:open-input-file", pic_file_open_input_file); 82 | pic_defun(pic, "scheme.file:open-binary-input-file", pic_file_open_input_file); 83 | pic_defun(pic, "scheme.file:open-output-file", pic_file_open_output_file); 84 | pic_defun(pic, "scheme.file:open-binary-output-file", pic_file_open_output_file); 85 | pic_defun(pic, "scheme.file:file-exists?", pic_file_exists_p); 86 | pic_defun(pic, "scheme.file:delete-file", pic_file_delete); 87 | } 88 | -------------------------------------------------------------------------------- /contrib/20.r7rs/src/load.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | #include 9 | 10 | static pic_value 11 | pic_load_load(pic_state *pic) 12 | { 13 | pic_value envid, port; 14 | char *fn; 15 | FILE *fp; 16 | 17 | pic_get_args(pic, "z|o", &fn, &envid); 18 | 19 | fp = fopen(fn, "r"); 20 | if (fp == NULL) { 21 | pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn)); 22 | } 23 | 24 | port = pic_fopen(pic, fp, "r"); 25 | 26 | pic_load(pic, port); 27 | 28 | pic_fclose(pic, port); 29 | 30 | return pic_undef_value(pic); 31 | } 32 | 33 | void 34 | pic_init_load(pic_state *pic) 35 | { 36 | pic_defun(pic, "scheme.load:load", pic_load_load); 37 | } 38 | -------------------------------------------------------------------------------- /contrib/20.r7rs/src/r7rs.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | 7 | void pic_init_file(pic_state *); 8 | void pic_init_load(pic_state *); 9 | void pic_init_system(pic_state *); 10 | void pic_init_time(pic_state *); 11 | 12 | void 13 | pic_init_r7rs(pic_state *pic) 14 | { 15 | pic_init_file(pic); 16 | pic_init_load(pic); 17 | pic_init_system(pic); 18 | pic_init_time(pic); 19 | 20 | pic_add_feature(pic, "r7rs"); 21 | } 22 | -------------------------------------------------------------------------------- /contrib/20.r7rs/src/system.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include 6 | 7 | #include "picrin.h" 8 | #include "picrin/extra.h" 9 | 10 | extern int picrin_argc; 11 | extern char **picrin_argv; 12 | extern char **picrin_envp; 13 | 14 | static pic_value 15 | pic_system_cmdline(pic_state *pic) 16 | { 17 | pic_value v = pic_nil_value(pic); 18 | int i; 19 | 20 | pic_get_args(pic, ""); 21 | 22 | for (i = 0; i < picrin_argc; ++i) { 23 | pic_push(pic, pic_cstr_value(pic, picrin_argv[i]), v); 24 | } 25 | return pic_reverse(pic, v); 26 | } 27 | 28 | static pic_value 29 | pic_system_exit(pic_state *pic) 30 | { 31 | pic_value v; 32 | int argc, status = EXIT_SUCCESS; 33 | 34 | argc = pic_get_args(pic, "|o", &v); 35 | if (argc == 1) { 36 | if (pic_float_p(pic, v)) { 37 | status = (int)pic_float(pic, v); 38 | } else if (pic_int_p(pic, v)) { 39 | status = pic_int(pic, v); 40 | } 41 | } 42 | 43 | pic_close(pic); 44 | 45 | exit(status); 46 | } 47 | 48 | static pic_value 49 | pic_system_emergency_exit(pic_state *pic) 50 | { 51 | pic_value v; 52 | int argc, status = EXIT_FAILURE; 53 | 54 | argc = pic_get_args(pic, "|o", &v); 55 | if (argc == 1) { 56 | if (pic_float_p(pic, v)) { 57 | status = (int)pic_float(pic, v); 58 | } else if (pic_int_p(pic, v)) { 59 | status = pic_int(pic, v); 60 | } 61 | } 62 | 63 | _Exit(status); 64 | } 65 | 66 | static pic_value 67 | pic_system_getenv(pic_state *pic) 68 | { 69 | char *str, *val; 70 | 71 | pic_get_args(pic, "z", &str); 72 | 73 | val = getenv(str); 74 | 75 | if (val == NULL) 76 | return pic_nil_value(pic); 77 | else 78 | return pic_cstr_value(pic, val); 79 | } 80 | 81 | static pic_value 82 | pic_system_getenvs(pic_state *pic) 83 | { 84 | char **envp; 85 | pic_value data = pic_nil_value(pic); 86 | size_t ai = pic_enter(pic); 87 | 88 | pic_get_args(pic, ""); 89 | 90 | if (! picrin_envp) { 91 | return pic_nil_value(pic); 92 | } 93 | 94 | for (envp = picrin_envp; *envp; ++envp) { 95 | pic_value key, val; 96 | int i; 97 | 98 | for (i = 0; (*envp)[i] != '='; ++i) 99 | ; 100 | 101 | key = pic_str_value(pic, *envp, i); 102 | val = pic_cstr_value(pic, getenv(pic_str(pic, key, NULL))); 103 | 104 | /* push */ 105 | data = pic_cons(pic, pic_cons(pic, key, val), data); 106 | 107 | pic_leave(pic, ai); 108 | pic_protect(pic, data); 109 | } 110 | 111 | return data; 112 | } 113 | 114 | void 115 | pic_init_system(pic_state *pic) 116 | { 117 | pic_defun(pic, "scheme.process-context:command-line", pic_system_cmdline); 118 | pic_defun(pic, "scheme.process-context:exit", pic_system_exit); 119 | pic_defun(pic, "scheme.process-context:emergency-exit", pic_system_emergency_exit); 120 | pic_defun(pic, "scheme.process-context:get-environment-variable", pic_system_getenv); 121 | pic_defun(pic, "scheme.process-context:get-environment-variables", pic_system_getenvs); 122 | } 123 | -------------------------------------------------------------------------------- /contrib/20.r7rs/src/time.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include 6 | 7 | #include "picrin.h" 8 | #include "picrin/extra.h" 9 | 10 | #define UTC_TAI_DIFF 35 11 | 12 | static pic_value 13 | pic_current_second(pic_state *pic) 14 | { 15 | time_t t; 16 | 17 | pic_get_args(pic, ""); 18 | 19 | time(&t); 20 | return pic_float_value(pic, (double)t + UTC_TAI_DIFF); 21 | } 22 | 23 | static pic_value 24 | pic_current_jiffy(pic_state *pic) 25 | { 26 | clock_t c; 27 | 28 | pic_get_args(pic, ""); 29 | 30 | c = clock(); 31 | return pic_int_value(pic, (int)c); /* The year 2038 problem :-| */ 32 | } 33 | 34 | static pic_value 35 | pic_jiffies_per_second(pic_state *pic) 36 | { 37 | pic_get_args(pic, ""); 38 | 39 | return pic_int_value(pic, CLOCKS_PER_SEC); 40 | } 41 | 42 | void 43 | pic_init_time(pic_state *pic) 44 | { 45 | pic_defun(pic, "scheme.time:current-second", pic_current_second); 46 | pic_defun(pic, "scheme.time:current-jiffy", pic_current_jiffy); 47 | pic_defun(pic, "scheme.time:jiffies-per-second", pic_jiffies_per_second); 48 | } 49 | -------------------------------------------------------------------------------- /contrib/20.r7rs/t/syntax-rules.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin "syntax-rules") 5 | 6 | (define-syntax extract? 7 | (syntax-rules () 8 | ((_ symb body _cont-t _cont-f) 9 | (letrec-syntax 10 | ((tr 11 | (syntax-rules (symb) 12 | ((_ x symb tail (cont-head symb-l . cont-args) cont-false) 13 | (cont-head (x . symb-l) . cont-args)) 14 | ((_ d (x . y) tail . rest) ; if body is a composite form, 15 | (tr x x (y . tail) . rest)) ; look inside 16 | ((_ d1 d2 () cont-t (cont-head symb-l . cont-args)) 17 | (cont-head (symb . symb-l) . cont-args)) 18 | ((_ d1 d2 (x . y) . rest) 19 | (tr x x y . rest))))) 20 | (tr body body () _cont-t _cont-f))))) 21 | 22 | (define-syntax extract 23 | (syntax-rules () 24 | ((_ symb body cont) 25 | (extract? symb body cont cont)))) 26 | 27 | (define-syntax mbi-dirty-v1 28 | (syntax-rules () 29 | ((_ _val _body) 30 | (let-syntax 31 | ((cont 32 | (syntax-rules () 33 | ((_ (symb) val body) 34 | (let ((symb val)) body))))) 35 | (extract i _body (cont () _val _body)))))) 36 | 37 | (test 11 (mbi-dirty-v1 10 (+ i 1))) 38 | 39 | (test-end) 40 | -------------------------------------------------------------------------------- /contrib/30.optional/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/30.optional/piclib/*.scm) 2 | CONTRIB_TESTS += test-optional 3 | 4 | test-optional: $(TEST_RUNNER) 5 | for test in `ls contrib/30.optional/t/*.scm`; do \ 6 | ./$(TEST_RUNNER) $$test; \ 7 | done 8 | -------------------------------------------------------------------------------- /contrib/30.optional/piclib/optional.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin optional) 2 | (import (scheme base)) 3 | 4 | (define-syntax optional 5 | (syntax-rules () 6 | ((_ args default) 7 | (let ((t args)) 8 | (if (null? t) default (car t)))))) 9 | 10 | (define-syntax let-optionals* 11 | (syntax-rules () 12 | ((_ args () body ...) 13 | (begin body ...)) 14 | ((_ args ((var default) . tail) body ...) 15 | (let* ((t args) 16 | (var (if (null? t) default (car t))) 17 | (remain (if (null? t) '() (cdr t)))) 18 | (let-optionals* remain tail body ...))) 19 | ((_ args rest body ...) 20 | (let ((rest args)) 21 | body ...)))) 22 | 23 | (export optional 24 | let-optionals*)) 25 | -------------------------------------------------------------------------------- /contrib/30.optional/t/test.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin optional) 3 | (picrin test)) 4 | 5 | (test 0 (optional '() 0)) 6 | (test 1 (optional '(1) 0)) 7 | 8 | (test '(0 0) (let-optionals* '() ((a 0) (b 0)) (list a b))) 9 | (test '(1 0) (let-optionals* '(1) ((a 0) (b 0)) (list a b))) 10 | (test '(1 2) (let-optionals* '(1 2) ((a 0) (b 0)) (list a b))) 11 | (test '(1 1) (let-optionals* '(1) ((a 0) (b a)) (list a b))) 12 | 13 | (test '(0 ()) (let-optionals* '() ((a 0) . r) (list a r))) 14 | (test '(1 ()) (let-optionals* '(1) ((a 0) . r) (list a r))) 15 | (test '(1 (2)) (let-optionals* '(1 2) ((a 0) . r) (list a r))) 16 | -------------------------------------------------------------------------------- /contrib/30.partcont/docs/doc.rst: -------------------------------------------------------------------------------- 1 | (picrin control) 2 | ---------------- 3 | 4 | Delimited control operators. 5 | 6 | - **(reset h)** 7 | - **(shift k)** 8 | 9 | Escape Continuation 10 | 11 | - **(escape f)** 12 | 13 | -------------------------------------------------------------------------------- /contrib/30.partcont/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/30.partcont/piclib/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/30.partcont/piclib/partcont.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin control) 2 | (import (scheme base)) 3 | 4 | ; based on paper "Representing Monads" (Filinski 1994) 5 | 6 | (define m #f) 7 | 8 | (define (abort t) 9 | (let ((v (t))) ; (t) may update m. do not place me like (m (t)) 10 | (m v))) 11 | 12 | (define (reset t) 13 | (let ((n m)) 14 | (call/cc 15 | (lambda (k) 16 | (set! m (lambda (r) 17 | (set! m n) 18 | (k r))) 19 | (abort t))))) 20 | 21 | (define (shift h) 22 | (call/cc 23 | (lambda (k) 24 | (abort 25 | (lambda () 26 | (h (lambda (v) 27 | (reset (lambda () 28 | (k v)))))))))) 29 | 30 | (define-syntax reset* 31 | (syntax-rules () 32 | ((_ expr ...) 33 | (reset (lambda () expr ...))))) 34 | 35 | (define-syntax shift* 36 | (syntax-rules () 37 | ((_ k expr ...) 38 | (shift (lambda (k) expr ...))))) 39 | 40 | (export (rename shift* shift) 41 | (rename reset* reset))) 42 | 43 | -------------------------------------------------------------------------------- /contrib/30.pretty-print/docs/doc.rst: -------------------------------------------------------------------------------- 1 | (picrin pretty-print) 2 | --------------------- 3 | 4 | Pretty-printer. 5 | 6 | - **(pretty-print obj)** 7 | 8 | Prints obj with human-readable indention to current-output-port. 9 | 10 | 11 | -------------------------------------------------------------------------------- /contrib/30.pretty-print/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += contrib/30.pretty-print/pretty-print.scm 2 | -------------------------------------------------------------------------------- /contrib/30.random/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_INITS += random 2 | CONTRIB_SRCS += $(wildcard contrib/30.random/src/*.c) 3 | CONTRIB_TESTS += test-random 4 | 5 | test-random: $(TEST_RUNNER) 6 | for test in `ls contrib/30.random/t/*.scm`; do \ 7 | ./$(TEST_RUNNER) $$test; \ 8 | done 9 | -------------------------------------------------------------------------------- /contrib/30.random/src/random.c: -------------------------------------------------------------------------------- 1 | #include "picrin.h" 2 | #include "picrin/extra.h" 3 | 4 | double genrand_real3(void); 5 | 6 | static pic_value 7 | pic_random_real(pic_state *pic) 8 | { 9 | pic_get_args(pic, ""); 10 | 11 | return pic_float_value(pic, genrand_real3()); 12 | } 13 | 14 | void 15 | pic_init_random(pic_state *pic) 16 | { 17 | pic_deflibrary(pic, "srfi.27"); 18 | pic_in_library(pic, "srfi.27"); 19 | pic_export(pic, 1, "random-real"); 20 | 21 | pic_defun(pic, "srfi.27:random-real", pic_random_real); 22 | } 23 | -------------------------------------------------------------------------------- /contrib/30.random/t/test.scm: -------------------------------------------------------------------------------- 1 | (import (srfi 27) 2 | (scheme base) 3 | (picrin test)) 4 | 5 | (test #t (procedure? random-real)) 6 | -------------------------------------------------------------------------------- /contrib/30.readline/example/simple-repl.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme read) 3 | (scheme eval) 4 | (scheme write) 5 | (picrin readline) 6 | (picrin readline history)) 7 | (let loop ((n 1)) 8 | (let ((input (readline "> "))) 9 | (if (eof-object? input) 10 | (newline) 11 | (begin 12 | (add-history input) 13 | (write (eval (read (open-input-string input)) '(picrin user))) 14 | (newline) 15 | (loop 1))))) 16 | -------------------------------------------------------------------------------- /contrib/30.readline/nitro.mk: -------------------------------------------------------------------------------- 1 | libedit_exists := $(shell pkg-config libedit --exists; echo $$?) 2 | 3 | ifeq ($(libedit_exists),0) 4 | CONTRIB_SRCS += contrib/30.readline/src/readline.c 5 | CONTRIB_INITS += readline 6 | CONTRIB_TESTS += test-readline 7 | LDFLAGS += `pkg-config libedit --libs` 8 | endif 9 | 10 | contrib/30.readline/src/readline.o: contrib/30.readline/src/readline.c 11 | $(CC) $(CFLAGS) -c -o $@ $< `pkg-config libedit --cflags` 12 | 13 | test-readline: $(TEST_RUNNER) 14 | for test in `ls contrib/30.readline/t/*.scm`; do \ 15 | ./$(TEST_RUNNER) $$test; \ 16 | done 17 | -------------------------------------------------------------------------------- /contrib/30.regexp/docs/doc.rst: -------------------------------------------------------------------------------- 1 | (picrin regexp) 2 | --------------- 3 | 4 | - **(regexp ptrn [flags])** 5 | 6 | Compiles pattern string into a regexp object. A string flags may contain any of #\g, #\i, #\m. 7 | 8 | - **(regexp? obj)** 9 | 10 | Judges if obj is a regexp object or not. 11 | 12 | - **(regexp-match re input)** 13 | 14 | Returns two values: a list of match strings, and a list of match indeces. 15 | 16 | - **(regexp-replace re input txt)** 17 | - **(regexp-split re input)** 18 | 19 | 20 | -------------------------------------------------------------------------------- /contrib/30.regexp/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_SRCS += contrib/30.regexp/src/regexp.c 2 | CONTRIB_INITS += regexp 3 | CONTRIB_TESTS += test-regexp 4 | 5 | test-regexp: $(TEST_RUNNER) 6 | for test in `ls contrib/30.regexp/t/*.scm`; do \ 7 | ./$(TEST_RUNNER) $$test; \ 8 | done 9 | -------------------------------------------------------------------------------- /contrib/30.regexp/t/test.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test) 3 | (picrin regexp)) 4 | 5 | (test #t (regexp? (regexp "simple"))) 6 | (test #f (regexp? "it\\s[s]e+ms\\s(reg)?exp")) 7 | (test-values (values '("abcd" "b") '(5 6)) (regexp-match (regexp "a(b)cd") "abdacabcd")) 8 | (test '("a" "b" "c" "d") (regexp-split (regexp ",") "a,b,c,d")) 9 | (test '("a" "b" "c" "d") (regexp-split (regexp "\\.+") "a.b....c.....d")) 10 | (test "a b c d" (regexp-replace (regexp ",") "a,b,c,d" " ")) 11 | (test "newline tab space " (regexp-replace (regexp "[\n\t ]") "newline 12 | tab space " " ")) 13 | -------------------------------------------------------------------------------- /contrib/30.test/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/30.test/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/40.procedure/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/40.procedure/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/40.procedure/procedure.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin procedure) 2 | (import (scheme base)) 3 | (export >> 4 | << 5 | constant 6 | identity) 7 | 8 | (define identity values) 9 | 10 | (define (constant . args) 11 | (lambda _ 12 | (apply values args))) 13 | 14 | (define (>> . fs) 15 | (if (null? fs) 16 | identity 17 | (let ((f (car fs)) 18 | (g (apply >> (cdr fs)))) 19 | (lambda args 20 | (call-with-values (lambda () (apply f args)) 21 | (lambda args 22 | (apply g args))))))) 23 | 24 | (define (<< . fs) 25 | (apply >> (reverse fs)))) 26 | -------------------------------------------------------------------------------- /contrib/40.srfi/docs/doc.rst: -------------------------------------------------------------------------------- 1 | SRFI libraries 2 | -------------- 3 | 4 | - `(srfi 1) 5 | `_ 6 | 7 | List library. 8 | 9 | - `(srfi 8) 10 | `_ 11 | 12 | ``receive`` macro. 13 | 14 | - `(srfi 17) 15 | `_ 16 | 17 | Generalized set! 18 | 19 | - `(srfi 26) 20 | `_ 21 | 22 | Cut/cute macros. 23 | 24 | - `(srfi 43) 25 | `_ 26 | 27 | Vector library. 28 | 29 | - `(srfi 60) 30 | `_ 31 | 32 | Bitwise operations. 33 | 34 | - `(srfi 95) 35 | `_ 36 | 37 | Sorting and Marging. 38 | 39 | - `(srfi 106) 40 | `_ 41 | 42 | Basic socket interface 43 | 44 | - `(srfi 111) 45 | `_ 46 | 47 | Boxes 48 | 49 | -------------------------------------------------------------------------------- /contrib/40.srfi/examples/106/simple-echo-client.scm: -------------------------------------------------------------------------------- 1 | ; A R7RS port of "simple echo client" example in SRFI 106 2 | ; 3 | ; Copyright (C) Takashi Kato (2012). All Rights Reserved. 4 | ; 5 | ; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ; of this software and associated documentation files (the "Software"), to deal 7 | ; in the Software without restriction, including without limitation the rights 8 | ; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ; copies of the Software, and to permit persons to whom the Software is 10 | ; furnished to do so, subject to the following conditions: 11 | ; 12 | ; The above copyright notice and this permission notice shall be included in 13 | ; all copies or substantial portions of the Software. 14 | ; 15 | ; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ; SOFTWARE. 22 | 23 | (import (scheme base) 24 | (srfi 106)) 25 | 26 | (define echo-client-socket (make-client-socket "localhost" "5000")) 27 | 28 | (socket-send echo-client-socket (string->utf8 "hello\r\n")) 29 | (socket-recv echo-client-socket (string-length "hello\r\n")) 30 | -------------------------------------------------------------------------------- /contrib/40.srfi/examples/106/simple-echo-server.scm: -------------------------------------------------------------------------------- 1 | ; A R7RS port of "simple echo server" example in SRFI 106 2 | ; 3 | ; Copyright (C) Takashi Kato (2012). All Rights Reserved. 4 | ; 5 | ; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ; of this software and associated documentation files (the "Software"), to deal 7 | ; in the Software without restriction, including without limitation the rights 8 | ; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ; copies of the Software, and to permit persons to whom the Software is 10 | ; furnished to do so, subject to the following conditions: 11 | ; 12 | ; The above copyright notice and this permission notice shall be included in 13 | ; all copies or substantial portions of the Software. 14 | ; 15 | ; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ; SOFTWARE. 22 | 23 | (import (scheme base) 24 | (srfi 106)) 25 | 26 | (define echo-server-socket (make-server-socket "5000")) 27 | 28 | (define (server-run) 29 | (define (get-line-from-binary-port bin) 30 | (utf8->string 31 | (call-with-port (open-output-bytevector) 32 | (lambda (out) 33 | (let loop ((b (read-u8 bin))) 34 | (case b 35 | ((10) (get-output-bytevector out)) 36 | ((13) (loop (read-u8 bin))) 37 | (else (write-u8 b out) (loop (read-u8 bin))))))))) 38 | 39 | (call-with-socket (socket-accept echo-server-socket) 40 | (lambda (sock) 41 | (let ((in (socket-input-port sock)) 42 | (out (socket-output-port sock))) 43 | (let loop ((r (get-line-from-binary-port in))) 44 | (write-bytevector (string->utf8 (string-append r "\r\n")) out) 45 | (loop (get-line-from-binary-port in))))))) 46 | 47 | (server-run) 48 | -------------------------------------------------------------------------------- /contrib/40.srfi/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_INITS += \ 2 | srfi_0 \ 3 | srfi_106 4 | CONTRIB_LIBS += \ 5 | contrib/40.srfi/srfi/0.scm\ 6 | contrib/40.srfi/srfi/1.scm\ 7 | contrib/40.srfi/srfi/8.scm\ 8 | contrib/40.srfi/srfi/17.scm\ 9 | contrib/40.srfi/srfi/26.scm\ 10 | contrib/40.srfi/srfi/43.scm\ 11 | contrib/40.srfi/srfi/60.scm\ 12 | contrib/40.srfi/srfi/95.scm\ 13 | contrib/40.srfi/srfi/106.scm\ 14 | contrib/40.srfi/srfi/111.scm 15 | CONTRIB_SRCS += \ 16 | contrib/40.srfi/src/0.c\ 17 | contrib/40.srfi/src/106.c 18 | CONTRIB_TESTS += test-srfi 19 | 20 | test-srfi: $(TEST_RUNNER) 21 | for test in `ls contrib/40.srfi/t/*.scm`; do \ 22 | ./$(TEST_RUNNER) "$$test"; \ 23 | done 24 | -------------------------------------------------------------------------------- /contrib/40.srfi/src/0.c: -------------------------------------------------------------------------------- 1 | #include "picrin.h" 2 | 3 | void 4 | pic_init_srfi_0(pic_state *pic) 5 | { 6 | pic_add_feature(pic, "srfi-0"); 7 | pic_add_feature(pic, "srfi-1"); 8 | pic_add_feature(pic, "srfi-8"); 9 | pic_add_feature(pic, "srfi-17"); 10 | pic_add_feature(pic, "srfi-26"); 11 | pic_add_feature(pic, "srfi-43"); 12 | pic_add_feature(pic, "srfi-60"); 13 | pic_add_feature(pic, "srfi-95"); 14 | pic_add_feature(pic, "srfi-106"); 15 | pic_add_feature(pic, "srfi-111"); 16 | } 17 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/0.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 0) 2 | (import (scheme base)) 3 | (export cond-expand)) 4 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/111.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 111) 2 | (import (scheme base)) 3 | 4 | (define-record-type 5 | (box value) 6 | box? 7 | (value unbox set-box!)) 8 | 9 | (export box box? 10 | unbox set-box!)) 11 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/17.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 17) 2 | 3 | (import (except (scheme base) set!) 4 | (prefix (only (scheme base) set!) %) 5 | (except (picrin base) set!) 6 | (srfi 1) 7 | (srfi 8)) 8 | 9 | (define-syntax set! 10 | (syntax-rules () 11 | ((_ (proc args ...) val) 12 | ((setter proc) args ... val)) 13 | ((_ var val) 14 | (%set! var val)))) 15 | 16 | (define setter 17 | (letrec ((setter 18 | (lambda (proc) 19 | (let ((attr (attribute proc))) 20 | (if (dictionary-has? attr '@@setter) 21 | (dictionary-ref attr '@@setter) 22 | (error "no setter found"))))) 23 | (set-setter! 24 | (lambda (proc setter) 25 | (dictionary-set! (attribute proc) '@@setter setter)))) 26 | (set-setter! setter set-setter!) 27 | setter)) 28 | 29 | (define (getter-with-setter get set) 30 | (let ((proc (lambda args (apply get args)))) 31 | (set! (setter proc) set) 32 | proc)) 33 | 34 | (set! (setter car) set-car!) 35 | (set! (setter cdr) set-cdr!) 36 | (set! (setter vector-ref) vector-set!) 37 | (set! (setter string-ref) string-set!) 38 | (set! (setter bytevector-u8-ref) bytevector-u8-set!) 39 | (set! (setter list-ref) list-set!) 40 | 41 | (export set! 42 | setter 43 | getter-with-setter)) 44 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/26.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 26) 2 | (import (scheme base) 3 | (picrin macro) 4 | (srfi 1)) 5 | 6 | (define-macro cut% 7 | (ir-macro-transformer 8 | (lambda (form inject compare?) 9 | (let ((slots (second form)) 10 | (combi (third form)) 11 | (se (cdddr form))) 12 | (cond ((null? se) 13 | `(lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))) 14 | ((and (symbol? (car se)) 15 | (compare? (car se) '<...>)) 16 | `(lambda (,@slots . rest-slot) (apply ,@combi rest-slot))) 17 | ((and (symbol? (car se)) 18 | (compare? (car se) '<>)) 19 | `(cut% (,@slots x) (,@combi x) ,@(cdr se))) 20 | (else `(cut% ,slots (,@combi ,(car se)) ,@(cdr se)))))))) 21 | 22 | (define-macro cute% 23 | (ir-macro-transformer 24 | (lambda (form inject compare?) 25 | (let ((slots (second form)) 26 | (binds (third form)) 27 | (combi (fourth form)) 28 | (se (cddddr form))) 29 | (cond ((null? se) 30 | `(let ,binds 31 | (lambda ,slots ((begin ,(car combi)) ,@(cdr combi))))) 32 | ((and (symbol? (car se)) 33 | (compare? (car se) '<...>)) 34 | `(let ,binds 35 | (lambda (,@slots . rest-slot) (apply ,@combi rest-slot)))) 36 | ((and (symbol? (car se)) 37 | (compare? (car se) '<>)) 38 | `(cute% (,@slots x) ,binds (,@combi x) ,@(cdr se))) 39 | (else 40 | `(cute% ,slots ((x ,(car se)) ,@binds) 41 | (,@combi x) ,@(cdr se)))))))) 42 | 43 | (define-macro cut 44 | (ir-macro-transformer 45 | (lambda (form inject compare?) 46 | `(cut% () () ,@(cdr form))))) 47 | 48 | (define-macro cute 49 | (ir-macro-transformer 50 | (lambda (form inject compare?) 51 | `(cute% () () () ,@(cdr form))))) 52 | 53 | (export cut cute)) 54 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/8.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 8) 2 | (import (scheme base)) 3 | 4 | (define-syntax receive 5 | (syntax-rules () 6 | ((receive formals expression body ...) 7 | (call-with-values (lambda () expression) 8 | (lambda formals body ...))))) 9 | 10 | (export receive)) 11 | -------------------------------------------------------------------------------- /contrib/40.srfi/srfi/95.scm: -------------------------------------------------------------------------------- 1 | (define-library (srfi 95) 2 | (import (scheme base) 3 | (scheme load) 4 | (srfi 1)) 5 | 6 | (define (list-sorted? ls less?) 7 | (let loop ((cur ls)) 8 | (if (<= (length cur) 1) 9 | #t 10 | (if (less? (second cur) (first cur)) 11 | #f 12 | (loop (cdr cur)))))) 13 | 14 | (define (identity x) 15 | x) 16 | 17 | (define (merge ls1 ls2 less? . opt-key) 18 | (let ((key (if (null? opt-key) identity (car opt-key)))) 19 | (let rec ((arg1 ls1) (arg2 ls2)) 20 | (cond ((null? arg1) 21 | arg2) 22 | ((null? arg2) 23 | arg1) 24 | ((less? (key (car arg1)) (key (car arg2))) 25 | (cons (car arg1) (rec (cdr arg1) arg2))) 26 | (else 27 | (cons (car arg2) (rec arg1 (cdr arg2)))))))) 28 | 29 | (define (merge-sub! ls1 ls2 less? key) 30 | (let rec ((arg1 ls1) (arg2 ls2)) 31 | (cond ((null? arg1) 32 | arg2) 33 | ((null? arg2) 34 | arg1) 35 | ((not (less? (key (car arg2)) (key (car arg1)))) 36 | (set-cdr! arg1 (rec (cdr arg1) arg2)) arg1) 37 | (else 38 | (set-cdr! arg2 (rec arg1 (cdr arg2))) arg2)))) 39 | 40 | (define (merge! ls1 ls2 less? . opt-key) 41 | (let ((key (if (null? opt-key) identity (car opt-key))) 42 | (c1 (car ls1)) 43 | (c2 (car ls2)) 44 | (d1 (cdr ls1)) 45 | (d2 (cdr ls2))) 46 | (when (less? (key c2) (key c1)) 47 | (set-car! ls1 c2) 48 | (set-car! ls2 c1) 49 | (set-cdr! ls1 d2) 50 | (set-cdr! ls2 d1)) 51 | (merge-sub! ls1 ls2 less? key))) 52 | 53 | (define (merge-sort ls less?) 54 | (if (<= (length ls) 1) 55 | ls 56 | (let* ((n (length ls)) 57 | (p (quotient n 2)) 58 | (as (take ls p)) 59 | (bs (drop ls p)) 60 | (sa (merge-sort as less?)) 61 | (sb (merge-sort bs less?))) 62 | (merge sa sb less?)))) 63 | 64 | (define (merge-sort! ls less?) 65 | (if (<= (length ls) 1) ls 66 | (let* ((n (length ls)) 67 | (p (quotient n 2)) 68 | (bs (drop ls p)) 69 | (as (take! ls p)) 70 | (sa (merge-sort! as less?)) 71 | (sb (merge-sort! bs less?))) 72 | (merge! sa sb less?)))) 73 | 74 | (export list-sorted? 75 | merge 76 | merge! 77 | merge-sort 78 | merge-sort!)) 79 | -------------------------------------------------------------------------------- /contrib/40.srfi/t/106.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (srfi 106) 3 | (picrin test)) 4 | 5 | (test-begin) 6 | 7 | ; The number 9600 has no meaning. I just borrowed from Rust. 8 | (define *test-port* 9600) 9 | (define (next-test-port) 10 | (set! *test-port* (+ *test-port* 1)) 11 | (number->string *test-port*)) 12 | 13 | (test #f (socket? '())) 14 | (let* ((port (next-test-port)) 15 | (server (make-server-socket port)) 16 | (client (make-client-socket "127.0.0.1" port))) 17 | (test #t (socket? server)) 18 | (test #t (socket? client))) 19 | 20 | (let* ((port (next-test-port)) 21 | (server (make-server-socket port)) 22 | (client (make-client-socket "127.0.0.1" port))) 23 | (test #t (socket? (socket-accept server)))) 24 | 25 | (let* ((port (next-test-port)) 26 | (server (make-server-socket port)) 27 | (client (make-client-socket "127.0.0.1" port)) 28 | (conn (socket-accept server))) 29 | (test 5 (socket-send conn (string->utf8 "hello"))) 30 | (test "hello" (utf8->string (socket-recv client 5)))) 31 | 32 | (let* ((port (next-test-port)) 33 | (sock (make-server-socket port))) 34 | (test #t (port? (socket-input-port sock))) 35 | (test #t (port? (socket-output-port sock)))) 36 | 37 | (test *ai-canonname* (socket-merge-flags *ai-canonname*)) 38 | (test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*)) 39 | (test *ai-canonname* (socket-purge-flags *ai-canonname*)) 40 | (test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*) 41 | *ai-all*)) 42 | (test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*) 43 | *ai-all*)) 44 | 45 | (test *af-inet* (address-family inet)) 46 | (test *af-inet6* (address-family inet6)) 47 | (test *af-unspec* (address-family unspec)) 48 | 49 | (test *sock-stream* (socket-domain stream)) 50 | (test *sock-dgram* (socket-domain datagram)) 51 | 52 | (test *ai-canonname* (address-info canoname)) 53 | (test *ai-numerichost* (address-info numerichost)) 54 | (test *ai-v4mapped* (address-info v4mapped)) 55 | (test *ai-all* (address-info all)) 56 | (test *ai-addrconfig* (address-info addrconfig)) 57 | (test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*) 58 | (address-info v4mapped addrconfig)) 59 | 60 | (test *ipproto-ip* (ip-protocol ip)) 61 | (test *ipproto-tcp* (ip-protocol tcp)) 62 | (test *ipproto-udp* (ip-protocol udp)) 63 | 64 | (test 0 (message-type none)) 65 | (test *msg-peek* (message-type peek)) 66 | (test *msg-oob* (message-type oob)) 67 | (test *msg-waitall* (message-type wait-all)) 68 | (test (socket-merge-flags *msg-oob* *msg-waitall*) 69 | (message-type oob wait-all)) 70 | 71 | (test *shut-rd* (shutdown-method read)) 72 | (test *shut-wr* (shutdown-method write)) 73 | (test *shut-rdwr* (shutdown-method read write)) 74 | (test *shut-rdwr* (shutdown-method write read)) 75 | 76 | (test-end) 77 | -------------------------------------------------------------------------------- /contrib/50.class/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/50.class/piclib/picrin/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/50.class/piclib/picrin/class.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin class) 2 | (import (scheme base)) 3 | 4 | (define-record-type class-type 5 | (make-class membership) 6 | class? 7 | (membership class-membership)) 8 | 9 | (define-syntax define-class 10 | (syntax-rules () 11 | ((define-class name membership) 12 | (define name (make-class membership))))) 13 | 14 | (define (instance? obj class) 15 | ((class-membership class) obj)) 16 | 17 | (define-class class?) 18 | 19 | (define-class (lambda (x) #t)) 20 | (define-class list?) 21 | (define-class procedure?) 22 | (define-class number?) 23 | (define-class boolean?) 24 | (define-class string?) 25 | 26 | (export make-class 27 | instance? 28 | define-class 29 | 30 | 31 | 32 | 33 | 34 | 35 | )) 36 | -------------------------------------------------------------------------------- /contrib/50.destructuring-bind/lambda.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin destructuring-bind) 2 | (import (picrin base) 3 | (picrin macro)) 4 | 5 | (define-syntax (destructuring-bind formal value . body) 6 | (cond 7 | ((identifier? formal) 8 | #`(let ((#,formal #,value)) 9 | #,@body)) 10 | ((pair? formal) 11 | #`(let ((value #,value)) 12 | (destructuring-bind #,(car formal) (car value) 13 | (destructuring-bind #,(cdr formal) (cdr value) 14 | #,@body)))) 15 | ((vector? formal) 16 | ;; TODO 17 | (error "fixme")) 18 | (else 19 | #`(if (equal? #,value '#,formal) 20 | (begin 21 | #,@body) 22 | (error "match failure" #,value '#,formal))))) 23 | 24 | (export destructuring-bind)) 25 | -------------------------------------------------------------------------------- /contrib/50.destructuring-bind/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/50.destructuring-bind/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/50.for/docs/doc.rst: -------------------------------------------------------------------------------- 1 | (picrin control list) 2 | --------------------- 3 | 4 | Monadic list operators. 5 | 6 | The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition:: 7 | 8 | (for (let ((a (in '(1 2 3))) 9 | (b (in '(2 3 4)))) 10 | (yield (+ a b)))) 11 | 12 | ;=> (5 6 7 6 7 8 7 8 9) 13 | 14 | All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one:: 15 | 16 | (for (yield (+ (in '(1 2 3)) 17 | (in '(4 5 6))))) 18 | 19 | The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements:: 20 | 21 | (for (let ((x (in (iota 10)))) 22 | (if (even? x) 23 | (yield x) 24 | (null)))) 25 | 26 | ;=> (0 2 4 6 8) 27 | 28 | This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical. 29 | 30 | - **(for expr)** 31 | 32 | [Macro] Executes expr in a list monad context. 33 | 34 | - **(in list)** 35 | 36 | Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded. 37 | 38 | - **(yield value)** 39 | 40 | Yields value from the monad context. The result of *for* will be a list of yielded values. 41 | 42 | - **(null . value)** 43 | 44 | Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class. 45 | 46 | 47 | -------------------------------------------------------------------------------- /contrib/50.for/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/50.for/piclib/*.scm) 2 | CONTRIB_TESTS += test-for 3 | 4 | test-for: $(TEST_RUNNER) 5 | for test in `ls contrib/50.for/t/*.scm`; do \ 6 | ./$(TEST_RUNNER) "$$test"; \ 7 | done 8 | -------------------------------------------------------------------------------- /contrib/50.for/piclib/for.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin control list) 2 | (import (scheme base) 3 | (picrin control)) 4 | 5 | (define unit list) 6 | 7 | (define (bind m f) 8 | (apply append (map f m))) 9 | 10 | (define-syntax reify 11 | (syntax-rules () 12 | ((_ expr) 13 | (reset (unit expr))))) 14 | 15 | (define (reflect m) 16 | (shift k (bind m k))) 17 | 18 | (define zero '()) 19 | 20 | (define plus append) 21 | 22 | (export unit 23 | bind 24 | zero 25 | plus 26 | reify 27 | reflect 28 | (rename reify for) 29 | (rename reflect in) 30 | (rename unit yield))) 31 | -------------------------------------------------------------------------------- /contrib/50.for/t/test.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin control list) 3 | (picrin test)) 4 | 5 | (test '(1 2 3) 6 | (for 7 | (in '(1 2 3)))) 8 | 9 | (test '((1 . a) (1 . b) (1 . c) (2 . a) (2 . b) (2 . c) (3 . a) (3 . b) (3 . c)) 10 | (for 11 | (let ((n (in '(1 2 3))) 12 | (c (in '(a b c)))) 13 | (cons n c)))) 14 | 15 | (define (fail) (in zero)) 16 | 17 | (test '((2 . a) (2 . b) (2 . c)) 18 | (for 19 | (let ((n (in '(1 2 3))) 20 | (c (in '(a b c)))) 21 | (if (even? n) 22 | (cons n c) 23 | (fail))))) 24 | -------------------------------------------------------------------------------- /contrib/50.option/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/50.option/*.scm) 2 | CONTRIB_TESTS += test-option 3 | 4 | test-option: $(TEST_RUNNER) 5 | for test in `ls contrib/50.option/t/*.scm`; do \ 6 | ./$(TEST_RUNNER) "$$test"; \ 7 | done 8 | -------------------------------------------------------------------------------- /contrib/50.option/option.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin control option) 2 | (import (scheme base) 3 | (picrin control) 4 | (picrin procedure)) 5 | 6 | (define unit identity) 7 | 8 | (define (bind m f) 9 | (and m (f m))) 10 | 11 | (define-syntax reify 12 | (syntax-rules () 13 | ((_ expr) 14 | (reset (unit expr))))) 15 | 16 | (define (reflect m) 17 | (shift k (bind m k))) 18 | 19 | (export unit 20 | bind 21 | reify 22 | reflect)) 23 | -------------------------------------------------------------------------------- /contrib/50.option/t/test.scm: -------------------------------------------------------------------------------- 1 | (import (picrin base) 2 | (picrin test) 3 | (picrin control option)) 4 | 5 | (define phonebook 6 | '(("Bob" . "01788 665242") 7 | ("Fred" . "01624 556442") 8 | ("Alice" . "01889 985333") 9 | ("Jane" . "01732 187565"))) 10 | 11 | (define nums 12 | '((one . 1) (two . 2) (three . 3) (four . 19))) 13 | 14 | (define num-dict 15 | (alist->dictionary nums)) 16 | 17 | (test '("01889 985333" . 3) 18 | (reify 19 | (let* ((a (reflect (assoc "Alice" phonebook))) 20 | (b (reflect (dictionary-ref num-dict 'three)))) 21 | (cons (cdr a) (cdr b))))) 22 | 23 | (test '#f 24 | (reify 25 | (let* ((a (reflect (assoc "Alice" phonebook))) 26 | (b (reflect (dictionary-ref num-dict 'five)))) 27 | (cons (cdr a) (cdr b))))) 28 | -------------------------------------------------------------------------------- /contrib/60.logic/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/60.logic/*.scm) 2 | CONTRIB_TESTS += test-logic 3 | 4 | test-logic: $(TEST_RUNNER) 5 | for test in `ls contrib/60.logic/t/*.scm`; do \ 6 | ./$(TEST_RUNNER) "$$test"; \ 7 | done 8 | -------------------------------------------------------------------------------- /contrib/60.peg/TODO: -------------------------------------------------------------------------------- 1 | - memoize 2 | - more procedures 3 | -------------------------------------------------------------------------------- /contrib/60.peg/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += contrib/60.peg/picrin/parser.scm contrib/60.peg/picrin/parser/string.scm 2 | 3 | CONTRIB_TESTS += test-peg 4 | 5 | test-peg: $(TEST_RUNNER) 6 | for test in `ls contrib/60.peg/t/*.scm`; do \ 7 | ./$(TEST_RUNNER) "$$test"; \ 8 | done 9 | -------------------------------------------------------------------------------- /contrib/60.peg/picrin/parser.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin parser) 2 | (import (scheme base) 3 | (picrin control) 4 | (picrin procedure)) 5 | (export parse 6 | ;; monadic 7 | reify 8 | reflect 9 | bind 10 | unit 11 | zero 12 | plus 13 | fapply 14 | ;; look ahead 15 | with 16 | without 17 | ;; eta 18 | lazy 19 | ;; aux 20 | choice 21 | optional 22 | many 23 | between) 24 | 25 | ;; type Parser i r = i -> Maybe (r, i) 26 | 27 | (define (parse rule input) 28 | (rule input)) 29 | 30 | ;; monadic operators 31 | 32 | (define-syntax reify 33 | (syntax-rules () 34 | ((_ expr) 35 | (reset (unit expr))))) 36 | 37 | (define (reflect x) 38 | (shift k (bind x k))) 39 | 40 | (define (bind m f) 41 | (lambda (i) 42 | (let ((x (m i))) 43 | (and x ((f (car x)) (cdr x)))))) 44 | 45 | (define (unit x) 46 | (lambda (i) 47 | `(,x . ,i))) 48 | 49 | (define zero 50 | (lambda (i) #f)) 51 | 52 | (define (plus a b) 53 | (lambda (i) 54 | (or (a i) (b i)))) 55 | 56 | (define (fapply f . args) 57 | (reify 58 | (let loop ((args args) (ps '())) 59 | (if (null? args) 60 | (apply f (reverse ps)) 61 | (loop (cdr args) (cons (reflect (car args)) ps)))))) 62 | 63 | ;; look ahead 64 | 65 | (define (with a) 66 | (lambda (i) 67 | (and (a i) `(#f . ,i)))) 68 | 69 | (define (without a) 70 | (lambda (i) 71 | (and (not (a i)) `(#f . ,i)))) 72 | 73 | ;; eta conversion 74 | 75 | (define-syntax lazy 76 | (syntax-rules () 77 | ((_ expr) 78 | (lambda (i) (expr i))))) 79 | 80 | ;; aux 81 | 82 | (define (choice . xs) 83 | (if (null? xs) 84 | zero 85 | (plus (car xs) (apply choice (cdr xs))))) 86 | 87 | (define (optional a) 88 | (choice a (unit #f))) 89 | 90 | (define (many a) 91 | (lazy 92 | (choice 93 | (reify 94 | (let* ((a (reflect a)) 95 | (b (reflect (many a)))) 96 | (cons a b))) 97 | null))) 98 | 99 | (define (between l x r) 100 | (fapply (>> list cadr) l x r))) 101 | -------------------------------------------------------------------------------- /contrib/60.peg/picrin/parser/string.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin parser string) 2 | (import (except (scheme base) string) 3 | (picrin parser)) 4 | (export string 5 | any-char 6 | eof 7 | parse-string) 8 | 9 | ;; string stream parser 10 | 11 | (define (string str) 12 | (lambda (i) 13 | (let ((i (car i)) (input (cdr i))) 14 | (let ((j (min (+ i (string-length str)) (string-length input)))) 15 | (and (equal? str (string-copy input i j)) 16 | `(,str . ,(cons j input))))))) 17 | 18 | (define any-char 19 | (lambda (i) 20 | (let ((i (car i)) (input (cdr i))) 21 | (and (< i (string-length input)) 22 | `(,(string-ref input i) . ,(cons (+ i 1) input)))))) 23 | 24 | (define eof 25 | (without any-char)) 26 | 27 | (define (parse-string rule input) 28 | (parse rule (cons 0 input)))) 29 | -------------------------------------------------------------------------------- /contrib/60.peg/t/peg.scm: -------------------------------------------------------------------------------- 1 | ;;; test case 2 | 3 | (import (scheme base) 4 | (picrin test) 5 | (picrin procedure) 6 | (picrin parser) 7 | (picrin parser string)) 8 | 9 | (test-begin "(picrin parser) and (picrin parser string)") 10 | 11 | (define LPAREN (string "(")) 12 | (define RPAREN (string ")")) 13 | 14 | (define PLUS (string "+")) 15 | (define MINUS (string "-")) 16 | 17 | (define ONE (fapply (constant 1) (string "1"))) 18 | 19 | (define S (lazy 20 | (fapply (>> list car) A eof))) 21 | 22 | (define A (lazy 23 | (choice 24 | (fapply (lambda (p _ a) (list '+ p a)) P PLUS A) 25 | (fapply (lambda (p _ a) (list '- p a)) P MINUS A) 26 | P))) 27 | 28 | (define P (lazy 29 | (choice 30 | (between LPAREN A RPAREN) 31 | ONE))) 32 | 33 | (define-syntax test-success 34 | (syntax-rules () 35 | ((_ expect str) 36 | (test (cons expect (cons (string-length str) str)) 37 | (parse-string S str))))) 38 | 39 | (test-success 1 "(1)") 40 | (test-success '(- (+ 1 1) 1) "((1+1)-1)") 41 | (test-success '(- (+ 1 1) 1) "((1+(1))-1)") 42 | (test-success '(+ 1 (- 1 (+ 1 (- 1 (+ 1 1))))) "(1+(1-(1+(1-(1+1)))))") 43 | (test-success '(+ 1 (+ 1(- 1 (+ 1 (- 1 (+ 1 1)))))) "(1+1+(1-(1+(1-(1+1)))))") 44 | 45 | (test-end) 46 | -------------------------------------------------------------------------------- /contrib/60.repl/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += contrib/60.repl/repl.scm 2 | CONTRIB_SRCS += contrib/60.repl/repl.c 3 | CONTRIB_INITS += repl 4 | -------------------------------------------------------------------------------- /contrib/60.repl/repl.c: -------------------------------------------------------------------------------- 1 | #include "picrin.h" 2 | #include "picrin/extra.h" 3 | 4 | #include 5 | 6 | static pic_value 7 | pic_repl_tty_p(pic_state *pic) 8 | { 9 | pic_get_args(pic, ""); 10 | 11 | return pic_bool_value(pic, (isatty(STDIN_FILENO))); 12 | } 13 | 14 | void 15 | pic_init_repl(pic_state *pic) 16 | { 17 | pic_defun(pic, "picrin.repl:tty?", pic_repl_tty_p); 18 | } 19 | -------------------------------------------------------------------------------- /contrib/70.main/main.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin main) 2 | (import (scheme base) 3 | (scheme read) 4 | (scheme write) 5 | (scheme process-context) 6 | (scheme load) 7 | (scheme eval) 8 | (picrin base) 9 | (picrin repl)) 10 | 11 | (define (print-help) 12 | (display "picrin scheme\n") 13 | (display "\n") 14 | (display "Usage: picrin [options] [file]\n") 15 | (display "\n") 16 | (display "Options:\n") 17 | (display " -e [program] run one liner script\n") 18 | (display " -l [file] load the file then enter repl\n") 19 | (display " -h or --help show this help\n")) 20 | 21 | (define (getopt) 22 | (let ((args (cdr (command-line)))) 23 | (if (null? args) 24 | (values 'repl #f) 25 | (case (string->symbol (car args)) 26 | ((-h --help) 27 | (print-help) 28 | (exit 1)) 29 | ((-e) 30 | (values 'line (cadr args))) 31 | ((-l) 32 | (values 'load (cadr args))) 33 | (else 34 | (values 'file (car args))))))) 35 | 36 | (define (exec-file filename) 37 | (load filename)) 38 | 39 | (define (exec-line str) 40 | (call-with-port (open-input-string str) 41 | (lambda (in) 42 | (let loop ((expr (read in))) 43 | (unless (eof-object? expr) 44 | (eval expr (find-library "picrin.user")) 45 | (loop (read in))))))) 46 | 47 | (define (main) 48 | (call-with-values getopt 49 | (lambda (type dat) 50 | (case type 51 | ((repl) (repl)) 52 | ((load) (load dat) (repl)) 53 | ((line) (exec-line dat)) 54 | ((file) (exec-file dat)))))) 55 | 56 | (export main)) 57 | -------------------------------------------------------------------------------- /contrib/70.main/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += contrib/70.main/main.scm 2 | -------------------------------------------------------------------------------- /contrib/80.protocol/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/80.protocol/piclib/picrin/*.scm) 2 | -------------------------------------------------------------------------------- /contrib/80.protocol/piclib/picrin/protocol.scm: -------------------------------------------------------------------------------- 1 | (define-library (picrin protocol) 2 | (import (scheme base) 3 | (srfi 1)) 4 | 5 | (import (picrin class)) 6 | 7 | (define method-table 8 | '()) 9 | 10 | (define (applicative? args types) 11 | (cond 12 | ((and (null? args) (null? types)) 13 | #true) 14 | ((and (pair? args) (pair? types)) 15 | (and (instance? (car args) (car types)) (applicative? (cdr args) (cdr types)))) 16 | (else 17 | #false))) 18 | 19 | (define (find-generic generic) 20 | (or (assq generic method-table) 21 | (error "no method alist found"))) 22 | 23 | (define (find-method generic args) 24 | (let ((methods (cdr (find-generic generic)))) 25 | (let ((m (filter (lambda (x) (applicative? args (cdr x))) methods))) 26 | (if (null? m) 27 | #f 28 | (car (car m)))))) 29 | 30 | (define (add-generic generic) 31 | (set! method-table (cons (cons generic '()) method-table))) 32 | 33 | (define (add-method generic method types) 34 | (let ((r (find-generic generic))) 35 | (set-cdr! r (cons (cons method types) (cdr r))))) 36 | 37 | (define (add-methods methods prototypes) 38 | (for-each 39 | (lambda (method prototype) 40 | (add-method (car prototype) method (cdr prototype))) 41 | methods 42 | prototypes)) 43 | 44 | (define make-generic 45 | (lambda () 46 | (letrec ((self (lambda args 47 | (let ((m (find-method self args))) 48 | (if m 49 | (apply m args) 50 | (error "method not found")))))) 51 | (add-generic self) 52 | self))) 53 | 54 | (define-syntax define-protocol 55 | (syntax-rules () 56 | ((define-protocol (name type ...) (method arg ...) ...) 57 | (begin 58 | (define method 59 | (make-generic)) 60 | ... 61 | (define name 62 | (lambda (type ...) 63 | (lambda methods 64 | (add-methods methods (list (list method arg ...) ...))))))))) 65 | 66 | (define-syntax define-instance 67 | (syntax-rules () 68 | ((define-instance (name arg ...) method ...) 69 | ((name arg ...) method ...)))) 70 | 71 | (export define-protocol 72 | define-instance)) 73 | -------------------------------------------------------------------------------- /contrib/90.array/nitro.mk: -------------------------------------------------------------------------------- 1 | CONTRIB_LIBS += $(wildcard contrib/90.array/*.scm) 2 | 3 | CONTRIB_TESTS += test-array 4 | 5 | test-array: $(TEST_RUNNER) 6 | ./$(TEST_RUNNER) contrib/90.array/t/array.scm 7 | -------------------------------------------------------------------------------- /contrib/90.array/t/array.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write) 3 | (picrin array) 4 | (picrin test)) 5 | 6 | (test-begin) 7 | 8 | (define ary (make-array)) 9 | 10 | (array-push! ary 1) 11 | (array-push! ary 2) 12 | (array-push! ary 3) 13 | 14 | (test 3 (array-pop! ary)) 15 | (test 2 (array-pop! ary)) 16 | (test 1 (array-pop! ary)) 17 | 18 | (array-unshift! ary 1) 19 | (array-unshift! ary 2) 20 | (array-unshift! ary 3) 21 | 22 | (test 3 (array-shift! ary)) 23 | (test 2 (array-shift! ary)) 24 | (test 1 (array-shift! ary)) 25 | 26 | (test-end) 27 | -------------------------------------------------------------------------------- /docs/capi.rst: -------------------------------------------------------------------------------- 1 | C API 2 | ===== 3 | 4 | You can write Picrin's extension by yourself from both sides of C and Scheme. This page describes the way to control the interpreter from the C world. 5 | 6 | Extension Library 7 | ----------------- 8 | 9 | If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library. 10 | 11 | * contrib/add/nitro.mk 12 | 13 | .. sourcecode:: cmake 14 | 15 | CONTRIB_INITS += add 16 | CONTRIB_SRCS += contrib/add/add.c 17 | 18 | * contrib/add/add.c 19 | 20 | .. sourcecode:: c 21 | 22 | #include "picrin.h" 23 | 24 | static pic_value 25 | pic_add(pic_state *pic) 26 | { 27 | double a, b; 28 | 29 | pic_get_args(pic, "ff", &a, &b); 30 | 31 | return pic_float_value(pic, a + b); 32 | } 33 | 34 | void 35 | pic_init_add(pic_state *pic) 36 | { 37 | pic_deflibrary (pic, "(picrin add)") { 38 | pic_defun(pic, "add", pic_add); 39 | } 40 | } 41 | 42 | After recompiling the interpreter, the library "(picrin add)" is available in the REPL, which library provides a funciton "add". 43 | 44 | User-data vs GC 45 | ^^^^^^^^^^^^^^^ 46 | 47 | When you use dynamic memory allocation inside C APIs, you must be caseful about Picrin's GC. Fortunately, we provides a set of wrapper functions for complete abstraction of GC. In the case below, the memory (de)allocators *create_foo* and *finalize_foo* are wrapped in pic_data object, so that when an instance of foo losts all references from others to it picrin can automatically finalize the orphan object. 48 | 49 | .. sourcecode:: c 50 | 51 | /** foo.c **/ 52 | #include 53 | #include "picrin.h" 54 | 55 | /* 56 | * C-side API 57 | */ 58 | 59 | struct foo { 60 | // blah blah blah 61 | }; 62 | 63 | struct foo * 64 | create_foo () 65 | { 66 | return malloc(sizeof(struct foo)); 67 | } 68 | 69 | void 70 | finalize_foo (void *foo) { 71 | struct foo *f = foo; 72 | free(f); 73 | } 74 | 75 | 76 | /* 77 | * picrin-side FFI interface 78 | */ 79 | 80 | static const pic_data_type foo_type = { "foo", finalize_foo }; 81 | 82 | static pic_value 83 | pic_create_foo(pic_state *pic) 84 | { 85 | struct foo *f; 86 | 87 | pic_get_args(pic, ""); // no args here 88 | 89 | f = create_foo(); 90 | 91 | return pic_data_value(pic, md, &foo_type); 92 | } 93 | 94 | void 95 | pic_init_foo(pic_state *pic) 96 | { 97 | pic_defun(pic, "create-foo", pic_create_foo); // (create-foo) 98 | } 99 | 100 | -------------------------------------------------------------------------------- /docs/deploy.rst: -------------------------------------------------------------------------------- 1 | Installation 2 | ============ 3 | 4 | Installation instructions below. 5 | 6 | 7 | Build 8 | ----- 9 | 10 | Just type `make` in the project root directory. You will find an executable binary newly created at bin/ directory. 11 | 12 | $ make 13 | 14 | When you are building picrin on x86_64 system, PIC_NAN_BOXING flag is automatically turned on (see include/picrin/config.h for detail). 15 | 16 | Install 17 | ------- 18 | 19 | `make install` target is provided. By default it installs picrin binary into `/usr/local/bin/`. 20 | 21 | $ make install 22 | 23 | Since picrin does not use autoconf, if you want to specify the install directory, pass the custom path to `make` via command line argument. 24 | 25 | $ make install prefix=/path/to/dir 26 | 27 | Requirement 28 | ----------- 29 | 30 | To build Picrin Scheme from source code, some external libraries are required: 31 | 32 | - perl 33 | - regex.h of POSIX.1 34 | - libedit (optional) 35 | 36 | Make command automatically turns on optional libraries if available. 37 | Picrin is mainly developed on Mac OS X and only tested on OS X or Ubuntu 14.04+. When you tried to run picrin on other platforms and found something was wrong with it, please send us an issue. 38 | -------------------------------------------------------------------------------- /docs/index.rst: -------------------------------------------------------------------------------- 1 | .. Picrin documentation master file, created by 2 | sphinx-quickstart on Sun May 18 06:06:12 2014. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Welcome to Picrin's documentation! 7 | ================================== 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | intro.rst 15 | deploy.rst 16 | lang.rst 17 | libs.rst 18 | contrib.rst 19 | capi.rst 20 | 21 | Indices and tables 22 | ================== 23 | 24 | * :ref:`genindex` 25 | * :ref:`modindex` 26 | * :ref:`search` 27 | 28 | -------------------------------------------------------------------------------- /docs/intro.rst: -------------------------------------------------------------------------------- 1 | Introduction 2 | ============ 3 | 4 | Picrin is a lightweight R7RS scheme implementation written in pure C89. It contains a reasonably fast VM, an improved hygienic macro system, usuful contribution libraries, and simple but powerful C interface. 5 | 6 | - R7RS compatible 7 | - Reentrant design (all VM states are stored in single global state object) 8 | - Bytecode interpreter 9 | - Direct threaded VM 10 | - Internal representation by nan-boxing (available only on x64) 11 | - Conservative call/cc implementation (VM stack and native c stack can interleave) 12 | - Exact GC (simple mark and sweep, partially reference count) 13 | - String representation by rope 14 | - Hygienic macro transformers (syntactic closures, explicit and implicit renaming macros) 15 | - Extended library syntax 16 | 17 | Homepage 18 | -------- 19 | 20 | Currently picrin is hosted on Github. You can freely send a bug report or pull-request, and fork the repository. 21 | 22 | https://github.com/picrin-scheme/picrin 23 | 24 | Documentation 25 | ------------- 26 | 27 | See http://picrin.readthedocs.org/ 28 | 29 | IRC 30 | --- 31 | 32 | There is a chat room on chat.freenode.org, channel #picrin. IRC logs here: https://botbot.me/freenode/picrin/ 33 | 34 | LICENSE 35 | ------- 36 | 37 | Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors 38 | 39 | Permission is hereby granted, free of charge, to any person obtaining a copy of 40 | this software and associated documentation files (the "Software"), to deal in 41 | the Software without restriction, including without limitation the rights to 42 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 43 | the Software, and to permit persons to whom the Software is furnished to do so, 44 | subject to the following conditions: 45 | 46 | The above copyright notice and this permission notice shall be included in all 47 | copies or substantial portions of the Software. 48 | 49 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 50 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 51 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 52 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 53 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 54 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 55 | -------------------------------------------------------------------------------- /etc/LIBRARY_IMPL.md: -------------------------------------------------------------------------------- 1 | # How to implement `define-library`? 2 | 3 | * define-library can be nested 4 | * expressions inside define-library are compiled and evaluated in order sequentially 5 | * import declarations inside define-library and on the top level are semantically the same 6 | * each define-library creates one syntactic-env 7 | * and the body is evaluated as if it's on the top level 8 | * so each `toplevel definitions`' results are registered to the global table 9 | * but their renamed symbols are known only to who imported the library. 10 | 11 | ## export table 12 | 13 | * import syntax destructively registers renamed symbols taken from export table of the specified library to syntactic env of the library 14 | * export syntax registers correspoindings of original and renamed symbols to export table of the current library 15 | * therefore, we need some kind of `forward declaration` support, because export syntax is usually placed at the beginning of source code. 16 | -------------------------------------------------------------------------------- /etc/R7RS/.gitignore: -------------------------------------------------------------------------------- 1 | /results.* 2 | /output 3 | /tmp 4 | -------------------------------------------------------------------------------- /etc/R7RS/COPYRIGHT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picrin-scheme/picrin/7b725f45eec13f90911007034e59fae33c527d89/etc/R7RS/COPYRIGHT -------------------------------------------------------------------------------- /etc/R7RS/README: -------------------------------------------------------------------------------- 1 | This directory contains a set of R6RS benchmarks. Some were 2 | originally collected by Richard Gabriel, while others were 3 | collected or written by Marc Feeley and Will Clinger. 4 | Abdulaziz Ghuloum converted about 50 of these benchmarks to 5 | R6RS libraries. R6RS libraries are non-portable by design, 6 | however, so Clinger rewrote the benchmarks as R6RS top-level 7 | programs and added a script for running the benchmarks on 8 | Unix systems. Clinger also added new benchmarks for R6RS. 9 | 10 | Files and directories: 11 | 12 | * bench : a shell script for running benchmarks 13 | * src : contains R6RS code for the benchmarks 14 | * inputs : contains inputs for the benchmarks 15 | * outputs : will hold the outputs of some benchmarks 16 | 17 | For succinct instructions on running benchmarks, run the 18 | bench script without any arguments: 19 | 20 | % ./bench 21 | 22 | The bench script creates a /tmp/larcenous directory to hold 23 | the source code constructed for the benchmarks. 24 | 25 | The bench script appends its results to files with names 26 | like results.Ikarus, results.Larceny, and so forth. 27 | 28 | Will 29 | 30 | ================================================================ 31 | 32 | NOTE: 33 | The nbody, trav1, and trav2 benchmarks have been dropped because 34 | the depend upon a non-portable order of evaluation. The sumloop 35 | benchmark has been dropped because it was essentially the same 36 | as the sum benchmark. The boyer benchmark has been replaced by 37 | the nboyer and sboyer benchmarks, which are fundamentally better 38 | benchmarks, with fewer bugs, and scalable. The gcold benchmark 39 | has been dropped temporarily because its initialization phase is 40 | so long compared to the benchmark phase, and the R6RS provides 41 | no portable way to time those phases separately. 42 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/ack.input: -------------------------------------------------------------------------------- 1 | 1 2 | 3 3 | 12 4 | 32765 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/array1.input: -------------------------------------------------------------------------------- 1 | 100 2 | 1000000 3 | 1000000 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/bib16: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picrin-scheme/picrin/7b725f45eec13f90911007034e59fae33c527d89/etc/R7RS/inputs/bib16 -------------------------------------------------------------------------------- /etc/R7RS/inputs/bibfreq.input: -------------------------------------------------------------------------------- 1 | 1 2 | "inputs/bib" 3 | ((the . 63922) (and . 51696) (of . 34615) (to . 13562) (that . 12913) 4 | (in . 12666) (he . 10420) (shall . 9838) (unto . 8997) (for . 8971)) 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/bibfreq2.input: -------------------------------------------------------------------------------- 1 | 1 2 | "inputs/bib" 3 | ((the . 63922) (and . 51696) (of . 34615) (to . 13562) (that . 12913) 4 | (in . 12666) (he . 10420) (shall . 9838) (unto . 8997) (for . 8971)) 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/browse.input: -------------------------------------------------------------------------------- 1 | 1000 2 | ((*a ?b *b ?b a *a a *b *a) 3 | (*a *b *b *a (*a) (*b)) 4 | (? ? * (b a) * ? ?)) 5 | 6 | (|\x38;37| |\x31;77| |\x31;090| |\x36;17| |\x36;61| |\x37;49| |\x36;28| 7 | |\x35;6| |\x38;26| |\x34;08| |\x31;035| |\x34;74| |\x33;20| |\x34;52| 8 | |\x36;72| |\x39;91| |\x31;55| |\x31;22| |\x37;93| |\x32;21| |\x37;16| 9 | |\x37;27| |\x38;48| |\x33;09| |\x31;44| |\x39;36| |\x31;00| |\x38;81| 10 | |\x32;87| |\x34;30| |\x32;3| |\x37;71| |\x32;32| |\x38;04| |\x39;58| 11 | |\x36;50| |\x31;068| |\x31;057| |\x34;63| |\x32;76| |\x31;046| |\x31;002| 12 | |\x31;99| |\x33;4| |\x37;38| |\x32;10| |\x35;40| |\x33;97| |\x33;42| 13 | |\x33;64| |\x37;82| |\x36;83| |\x38;9| |\x33;75| |\x31;66| |\x35;95| 14 | |\x38;92| |\x37;05| |\x35;07| |\x36;39| |\x33;31| |\x31;88| |\x32;43| 15 | |\x34;41| |\x31;013| |\x31;079| |\x36;7| |\x32;98| |\x33;86| |\x35;73| 16 | |\x38;59| |\x31;33| |\x37;60| |\x31;2| |\x35;29| |\x38;15| |\x31;11| 17 | |\x34;96| |\x34;5| |\x32;65| |\x39;25| |\x39;03| |\x32;54| |\x37;8| 18 | |\x35;51| |\x36;06| |\x34;85| |\x35;18| |\x34;19| |\x38;70| |\x35;62| 19 | |\x31;| |\x33;53| |\x39;80| |\x36;94| |\x39;14| |\x39;69| |\x39;47| 20 | |\x35;84| |\x31;024|) 21 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/bv2string.input: -------------------------------------------------------------------------------- 1 | 2 2 | 1000 ; number of random stress tests 3 | 100 ; twice average length of random test string 4 | 0 ; number of tests that should fail 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/cat.input: -------------------------------------------------------------------------------- 1 | 25 2 | "inputs/bib" 3 | "outputs/cat.output" 4 | ignored 5 | 6 | 7 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/cat2.input: -------------------------------------------------------------------------------- 1 | 25 2 | "inputs/bib" 3 | "outputs/cat2.output" 4 | ignored 5 | 6 | 7 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/cat3.input: -------------------------------------------------------------------------------- 1 | 10 2 | "inputs/bib16" 3 | "outputs/cat3.output" 4 | ignored 5 | 6 | 7 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/conform.input: -------------------------------------------------------------------------------- 1 | 200 2 | (a b "c" "d") 3 | 4 | ("(((b v d) ^ a) v c)" 5 | "(c ^ d)" 6 | "(b v (a ^ d))" 7 | "((a v d) ^ b)" 8 | "(b v d)" 9 | "(b ^ (a v c))" 10 | "(a v (c ^ d))" 11 | "((b v d) ^ a)" 12 | "(c v (a v d))" 13 | "(a v c)" 14 | "(d v (b ^ (a v c)))" 15 | "(d ^ (a v c))" 16 | "((a ^ d) v c)" 17 | "((a ^ b) v d)" 18 | "(((a v d) ^ b) v (a ^ d))" 19 | "(b ^ d)" 20 | "(b v (a v d))" 21 | "(a ^ c)" 22 | "(b ^ (c v d))" 23 | "(a ^ b)" 24 | "(a v b)" 25 | "((a ^ d) ^ b)" 26 | "(a ^ d)" 27 | "(a v d)" 28 | "d" 29 | "(c v d)" 30 | "a" 31 | "b" 32 | "c" 33 | "any" 34 | "none") 35 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/cpstak.input: -------------------------------------------------------------------------------- 1 | 5 2 | 32 3 | 16 4 | 8 5 | 9 6 | 7 | 8 | ; The old inputs and output for cpstak were: 9 | 10 | 1700 11 | 18 12 | 12 13 | 6 14 | 7 15 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/ctak.input: -------------------------------------------------------------------------------- 1 | 1 2 | 32 3 | 16 4 | 8 5 | 9 6 | 7 | 8 | ; The old inputs and output for ctak were: 9 | 10 | 160 11 | 18 12 | 12 13 | 6 14 | 7 15 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/dderiv.input: -------------------------------------------------------------------------------- 1 | 10000000 2 | 3 | (+ (* 3 x x) (* a x x) (* b x) 5) 4 | 5 | (+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) 6 | (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) 7 | (* (* b x) (+ (/ 0 b) (/ 1 x))) 8 | 0) 9 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/deriv.input: -------------------------------------------------------------------------------- 1 | 10000000 2 | 3 | (+ (* 3 x x) (* a x x) (* b x) 5) 4 | 5 | (+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x))) 6 | (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x))) 7 | (* (* b x) (+ (/ 0 b) (/ 1 x))) 8 | 0) 9 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/destruc.input: -------------------------------------------------------------------------------- 1 | 1000 2 | 600 3 | 50 4 | 5 | ((1 1 2) 6 | (1 1 1) 7 | (1 1 1 2) 8 | (1 1 1 1) 9 | (1 1 1 1 2) 10 | (1 1 1 1 2) 11 | (1 1 1 1 2) 12 | (1 1 1 1 2) 13 | (1 1 1 1 2) 14 | (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3)) 15 | 16 | 17 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/diviter.input: -------------------------------------------------------------------------------- 1 | 1000000 2 | 1000 3 | 500 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/divrec.input: -------------------------------------------------------------------------------- 1 | 1000000 2 | 1000 3 | 500 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/dynamic.input: -------------------------------------------------------------------------------- 1 | 200 2 | "inputs/dynamic.data" 3 | ((218 . 455) (6 . 1892) (2204 . 446)) 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/earley.input: -------------------------------------------------------------------------------- 1 | 1 2 | 15 3 | 2674440 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/equal.input: -------------------------------------------------------------------------------- 1 | 100 2 | 100 3 | 8 4 | 1000 5 | 2000 6 | 5000 7 | #t 8 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/fft.input: -------------------------------------------------------------------------------- 1 | 50 2 | 65536 3 | 0.0 4 | 0.0 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/fib.input: -------------------------------------------------------------------------------- 1 | 1 2 | 40 3 | 102334155 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/fibc.input: -------------------------------------------------------------------------------- 1 | 10 2 | 30 3 | 832040 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/fibfp.input: -------------------------------------------------------------------------------- 1 | 10 2 | 35.0 3 | 9227465.0 -------------------------------------------------------------------------------- /etc/R7RS/inputs/gcbench.input: -------------------------------------------------------------------------------- 1 | 1 2 | 20 3 | 0 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/graphs.input: -------------------------------------------------------------------------------- 1 | 1 2 | 7 3 | 213829 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/hashtable0.input: -------------------------------------------------------------------------------- 1 | 25 ; number of iterations 2 | 100000 ; number of items added to stress the eq? hashtable 3 | 100000 ; number of items added to stress the eqv? hashtable 4 | 102005 ; number of items in table at end of benchmark 5 | ; (always 2005 plus number of items added to stress the table) 6 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/lattice.input: -------------------------------------------------------------------------------- 1 | 10 2 | 44 3 | 120549 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/listsort.input: -------------------------------------------------------------------------------- 1 | 1 2 | 0 3 | #x10ffff 4 | ignored 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/matrix.input: -------------------------------------------------------------------------------- 1 | 1000 2 | 5 3 | 5 4 | 5 | (((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1) 6 | (1 1 -1 -1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1)) 7 | ((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1) 8 | (1 1 -1 1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1)) 9 | ((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1) 10 | (1 1 -1 1 -1) (1 -1 1 -1 1) (1 -1 -1 1 1)) 11 | ((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1) 12 | (1 1 -1 1 1) (1 -1 1 1 -1) (1 -1 -1 -1 1)) 13 | ((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1) 14 | (1 1 -1 1 1) (1 -1 1 1 1) (1 -1 -1 -1 -1))))) 15 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/maze.input: -------------------------------------------------------------------------------- 1 | 5000 2 | 20 3 | 7 4 | (#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline 5 | #\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline 6 | #\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline 7 | #\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline 8 | #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline 9 | #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline 10 | #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline 11 | #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline 12 | #\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline 13 | #\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline 14 | #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline 15 | #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline 16 | #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline 17 | #\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline 18 | #\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline 19 | #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline 20 | #\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline 21 | #\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline 22 | #\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline 23 | #\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline 24 | #\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline 25 | #\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline 26 | #\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline 27 | #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline 28 | #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline 29 | #\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline 30 | #\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline 31 | #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline 32 | #\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline 33 | #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline 34 | #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline 35 | #\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline 36 | #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline 37 | #\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline 38 | #\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline 39 | #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline 40 | #\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline 41 | #\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline 42 | #\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline 43 | #\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline 44 | #\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline 45 | #\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline) 46 | 47 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/mazefun.input: -------------------------------------------------------------------------------- 1 | 5000 2 | 11 3 | 11 4 | ((_ * _ _ _ _ _ _ _ _ _) 5 | (_ * * * * * * * _ * *) 6 | (_ _ _ * _ _ _ * _ _ _) 7 | (_ * _ * _ * _ * _ * _) 8 | (_ * _ _ _ * _ * _ * _) 9 | (* * _ * * * * * _ * _) 10 | (_ * _ _ _ _ _ _ _ * _) 11 | (_ * _ * _ * * * * * *) 12 | (_ _ _ * _ _ _ _ _ _ _) 13 | (_ * * * * * * * _ * *) 14 | (_ * _ _ _ _ _ _ _ _ _)) 15 | 16 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/mbrot.input: -------------------------------------------------------------------------------- 1 | 1000 2 | 75 3 | 5 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/mbrotZ.input: -------------------------------------------------------------------------------- 1 | 1000 2 | 75 3 | 5 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/mperm.input: -------------------------------------------------------------------------------- 1 | ; The traditional parameters for this benchmark are 10:9:2:1, 2 | ; but that's too small for modern computers. 3 | ; 4 | ; The new parameters for this benchmark are 20:10:2:1. 5 | ; M: N:K:L 6 | ; 7 | ; N=10 means the benchmark starts by generating a list of all 8 | ; 10! = 3628800 permutations of the first 10 integers, allocating 9 | ; 13492889 pairs (a little over 100 megabytes on 32-bit machines 10 | ; with two-word pairs), all of which goes into the generated list. 11 | ; (That is, the first phase of the benchmark generates absolutely 12 | ; no garbage.) This represents a savings of about 63% over the 13 | ; storage that would be required by an unshared list of permuations. 14 | ; The generated permutations are in order of a gray code that bears 15 | ; no obvious relationship to a lexicographic order. 16 | ; 17 | ; Then M*(K-L) = 20*(2-1) = 20 more such lists are allocated. 18 | ; 19 | ; The live storage peaks at K=2 times the storage occupied by a 20 | ; single list of all N! permutations. 21 | ; 22 | ; At the end of each of the M=20 iterations, the oldest L/K = 1/2 23 | ; of the peak storage becomes garbage. Object lifetimes (measured 24 | ; in bytes or pairs allocated) are distributed uniformly between 25 | ; L/K times the peak storage and the peak storage itself. 26 | 27 | 20 ; M (number of iterations) 28 | 10 ; N (length of each permutation) 29 | 2 ; K (size of queue) 30 | 1 ; L (number of old copies removed when queue is filled) 31 | 32 | ; Note: the result below is ignored, since it can be 33 | ; computed from N above. 34 | 35 | 16329600 ; result (/ (* N (+ N 1) (factorial N)) 2) 36 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/nboyer.input: -------------------------------------------------------------------------------- 1 | 1 2 | 4 3 | 16445406 ; if the input is 4 4 | 51507739 ; if the input is 5 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/normalization.input: -------------------------------------------------------------------------------- 1 | 5 2 | 3 | ; Get NormalizationTest.txt from http://www.unicode.org/ 4 | 5 | "inputs/NormalizationTest.txt" 6 | 7 | ; Number of normalization tests for Unicode 5.0.0 8 | 9 | 351980 10 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/nqueens.input: -------------------------------------------------------------------------------- 1 | 10 2 | 13 3 | 73712 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/ntakl.input: -------------------------------------------------------------------------------- 1 | 2 2 | 3 | (32 31 30 29 28 27 26 25 24 23 22 21 4 | 20 19 18 17 16 15 14 13 12 11 5 | 10 9 8 7 6 5 4 3 2 1) 6 | 7 | ( 16 15 14 13 12 11 8 | 10 9 8 7 6 5 4 3 2 1) 9 | 10 | (8 7 6 5 4 3 2 1) 11 | 12 | 9 13 | 14 | 15 | ; The old inputs and output for takl were: 16 | 17 | 600 18 | (a list of 18 elements) 19 | (a list of 12 elements) 20 | (a list of 6 elements) 21 | 7 22 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/nucleic.input: -------------------------------------------------------------------------------- 1 | 50 2 | () 3 | 33.797594890762724 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/paraffins.input: -------------------------------------------------------------------------------- 1 | 5 2 | 23 3 | 5731580 4 | 5 | 6 | ; the following seems to take too much memory 7 | 8 | 5 9 | 24 10 | 14490245 11 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/parsing.input: -------------------------------------------------------------------------------- 1 | 2500 2 | "inputs/parsing.data" 3 | (should return this list) 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/parsing16.data: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picrin-scheme/picrin/7b725f45eec13f90911007034e59fae33c527d89/etc/R7RS/inputs/parsing16.data -------------------------------------------------------------------------------- /etc/R7RS/inputs/peval.input: -------------------------------------------------------------------------------- 1 | 1000 2 | 3 | ; example8 4 | 5 | (lambda (input) 6 | (letrec ((reverse (lambda (in result) 7 | (if (pair? in) 8 | (reverse (cdr in) (cons (car in) result)) 9 | result)))) 10 | (reverse input '()))) 11 | 12 | ((a b c d e f g h i j k l m n o p q r s t u v w x y z)) 13 | 14 | (lambda () 15 | (list 'z 'y 'x 'w 'v 'u 't 's 'r 'q 'p 'o 'n 16 | 'm 'l 'k 'j 'i 'h 'g 'f 'e 'd 'c 'b 'a)) 17 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/pi.input: -------------------------------------------------------------------------------- 1 | 1 2 | 50 3 | 500 4 | 50 5 | 6 | ((314159265358979323846264338327950288419716939937507 7 | -54 8 | 124) 9 | (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170673 10 | -51 11 | -417) 12 | (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408122 13 | -57 14 | -819) 15 | (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038195 16 | -76 17 | 332) 18 | (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019089 19 | -83 20 | 477) 21 | (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141268 22 | -72 23 | -2981) 24 | (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536431 25 | -70 26 | -2065) 27 | (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116089 28 | -79 29 | 1687) 30 | (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118542 31 | -92 32 | -2728) 33 | (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194907 34 | -76 35 | -3726)) 36 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/pnpoly.input: -------------------------------------------------------------------------------- 1 | 500000 2 | #(0. 1. 1. 0. 0. 1. -.5 -1. -1. -2. -2.5 -2. -1.5 -.5 1. 1. 0. -.5 -1. -.5) 3 | #(0. 0. 1. 1. 2. 3. 2. 3. 0. -.5 -1. -1.5 -2. -2. -1.5 -1. -.5 -1. -1. -.5) 4 | 6 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/primes.input: -------------------------------------------------------------------------------- 1 | 5000 2 | 1000 3 | (2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 4 | 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 5 | 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 6 | 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 7 | 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 8 | 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 9 | 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 10 | 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 11 | 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 12 | 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 13 | 991 997) 14 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/puzzle.input: -------------------------------------------------------------------------------- 1 | 500 2 | 511 3 | 2005 4 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/quicksort.input: -------------------------------------------------------------------------------- 1 | 2500 2 | 10000 3 | 1000000 4 | ignored 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/ray.input: -------------------------------------------------------------------------------- 1 | 20 2 | 1 3 | "outputs/ray.output" 4 | ok 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/read0.input: -------------------------------------------------------------------------------- 1 | 1 2 | 0 3 | #x10ffff 4 | ignored 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/read1.input: -------------------------------------------------------------------------------- 1 | 2500 2 | 3 | "inputs/parsing.data" 4 | 5 | (should return this list) 6 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/read2.input: -------------------------------------------------------------------------------- 1 | 2500 2 | 3 | "inputs/parsing.data" 4 | 5 | (should return this list) 6 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/read3.input: -------------------------------------------------------------------------------- 1 | 2500 2 | 3 | "inputs/parsing16.data" 4 | 5 | (should return this list) 6 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/sboyer.input: -------------------------------------------------------------------------------- 1 | 1 2 | 5 3 | 51507739 ; if the input is 5 4 | 16445406 ; if the input is 4 5 | -------------------------------------------------------------------------------- /etc/R7RS/inputs/scheme.input: -------------------------------------------------------------------------------- 1 | 100000 2 | 3 | (let () 4 | 5 | (define (sort-list obj pred) 6 | 7 | (define (loop l) 8 | (if (and (pair? l) (pair? (cdr l))) 9 | (split l '() '()) 10 | l)) 11 | 12 | (define (split l one two) 13 | (if (pair? l) 14 | (split (cdr l) two (cons (car l) one)) 15 | (merge (loop one) (loop two)))) 16 | 17 | (define (merge one two) 18 | (cond ((null? one) two) 19 | ((pred (car two) (car one)) 20 | (cons (car two) 21 | (merge (cdr two) one))) 22 | (else 23 | (cons (car one) 24 | (merge (cdr one) two))))) 25 | 26 | (loop obj)) 27 | 28 | (sort-list '("one" "two" "three" "four" "five" "six" 29 | "seven" "eight" "nine" "ten" "eleven" "twelve" 30 | "thirteen" "fourteen" "fifteen" "sixteen" 31 | "seventeen" "eighteen" "nineteen" "twenty" 32 | "twentyone" "twentytwo" "twentythree" "twentyfour" 33 | "twentyfive" "twentysix" "twentyseven" "twentyeight" 34 | "twentynine" "thirty") 35 | stringstring input2)) 18 | (s1 (number->string input1)) 19 | (name "ack")) 20 | (run-r7rs-benchmark 21 | (string-append name ":" s1 ":" s2) 22 | count 23 | (lambda () (ack (hide count input1) (hide count input2))) 24 | (lambda (result) (= result output))))) 25 | 26 | (include "src/common.sch") 27 | -------------------------------------------------------------------------------- /etc/R7RS/src/array1.sch: -------------------------------------------------------------------------------- 1 | ;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks. 2 | 3 | (import (scheme base) 4 | (scheme write) 5 | (scheme read)) 6 | 7 | (define (create-x n) 8 | (define result (make-vector n)) 9 | (do ((i 0 (+ i 1))) 10 | ((>= i n) result) 11 | (vector-set! result i i))) 12 | 13 | (define (create-y x) 14 | (let* ((n (vector-length x)) 15 | (result (make-vector n))) 16 | (do ((i (- n 1) (- i 1))) 17 | ((< i 0) result) 18 | (vector-set! result i (vector-ref x i))))) 19 | 20 | (define (my-try n) 21 | (vector-length (create-y (create-x n)))) 22 | 23 | (define (go m n) 24 | (let loop ((repeat m) 25 | (result '())) 26 | (if (> repeat 0) 27 | (loop (- repeat 1) (my-try n)) 28 | result))) 29 | 30 | (define (main) 31 | (let* ((count (read)) 32 | (input1 (read)) 33 | (output (read)) 34 | (s2 (number->string count)) 35 | (s1 (number->string input1)) 36 | (name "array1")) 37 | (run-r7rs-benchmark 38 | (string-append name ":" s1 ":" s2) 39 | 1 40 | (lambda () (go (hide count count) (hide count input1))) 41 | (lambda (result) (equal? result output))))) 42 | 43 | (include "src/common.sch") 44 | -------------------------------------------------------------------------------- /etc/R7RS/src/bibfreq.sch: -------------------------------------------------------------------------------- 1 | ;;; find the most frequently referenced word in the bible. 2 | ;;; aziz ghuloum (Nov 2007) 3 | ;;; modified (slightly) by Will Clinger (Nov 2007) 4 | 5 | (import (rnrs base) 6 | (rnrs unicode) 7 | (rnrs sorting) 8 | (rnrs hashtables) 9 | (rnrs io simple)) 10 | 11 | (define (fill input-file h) 12 | (let ((p (open-input-file input-file))) 13 | (define (put ls) 14 | (hashtable-update! h 15 | (string->symbol 16 | (list->string 17 | (reverse ls))) 18 | (lambda (x) (+ x 1)) 19 | 0)) 20 | (define (alpha ls) 21 | (let ((c (read-char p))) 22 | (cond 23 | ((eof-object? c) 24 | (put ls)) 25 | ((char-alphabetic? c) 26 | (alpha (cons (char-downcase c) ls))) 27 | (else (put ls) (non-alpha))))) 28 | (define (non-alpha) 29 | (let ((c (read-char p))) 30 | (cond 31 | ((eof-object? c) (values)) 32 | ((char-alphabetic? c) 33 | (alpha (list (char-downcase c)))) 34 | (else (non-alpha))))) 35 | (non-alpha) 36 | (close-input-port p))) 37 | 38 | (define (list-head ls n) 39 | (cond 40 | ((or (zero? n) (null? ls)) '()) 41 | (else (cons (car ls) (list-head (cdr ls) (- n 1)))))) 42 | 43 | (define (go input-file) 44 | (let ((h (make-eq-hashtable))) 45 | (fill input-file h) 46 | (let-values (((keys vals) (hashtable-entries h))) 47 | (let ((ls (map cons 48 | (vector->list keys) 49 | (vector->list vals)))) 50 | (list-head 51 | (list-sort (lambda (a b) (> (cdr a) (cdr b))) ls) 52 | 10))))) 53 | 54 | (define (main) 55 | (let* ((count (read)) 56 | (input1 (read)) 57 | (output (read)) 58 | (s2 (number->string count)) 59 | (s1 input1) 60 | (name "bibfreq")) 61 | (run-r6rs-benchmark 62 | (string-append name ":" s2) 63 | 1 64 | (lambda () (go (hide count input1))) 65 | (lambda (result) (equal? result output))))) 66 | -------------------------------------------------------------------------------- /etc/R7RS/src/bibfreq2.sch: -------------------------------------------------------------------------------- 1 | ;;; find the most frequently referenced word in the bible. 2 | ;;; aziz ghuloum (Nov 2007) 3 | ;;; modified by Will Clinger (Nov 2007) 4 | ;;; to use symbol-hash instead of eq? hashtables 5 | 6 | (import (rnrs base) 7 | (rnrs unicode) 8 | (rnrs sorting) 9 | (rnrs hashtables) 10 | (rnrs io simple)) 11 | 12 | (define (fill input-file h) 13 | (let ((p (open-input-file input-file))) 14 | (define (put ls) 15 | (hashtable-update! h 16 | (string->symbol 17 | (list->string 18 | (reverse ls))) 19 | (lambda (x) (+ x 1)) 20 | 0)) 21 | (define (alpha ls) 22 | (let ((c (read-char p))) 23 | (cond 24 | ((eof-object? c) 25 | (put ls)) 26 | ((char-alphabetic? c) 27 | (alpha (cons (char-downcase c) ls))) 28 | (else (put ls) (non-alpha))))) 29 | (define (non-alpha) 30 | (let ((c (read-char p))) 31 | (cond 32 | ((eof-object? c) (values)) 33 | ((char-alphabetic? c) 34 | (alpha (list (char-downcase c)))) 35 | (else (non-alpha))))) 36 | (non-alpha) 37 | (close-input-port p))) 38 | 39 | (define (list-head ls n) 40 | (cond 41 | ((or (zero? n) (null? ls)) '()) 42 | (else (cons (car ls) (list-head (cdr ls) (- n 1)))))) 43 | 44 | (define (go input-file) 45 | (let ((h (make-hashtable symbol-hash eq?))) 46 | (fill input-file h) 47 | (let-values (((keys vals) (hashtable-entries h))) 48 | (let ((ls (map cons 49 | (vector->list keys) 50 | (vector->list vals)))) 51 | (list-head 52 | (list-sort (lambda (a b) (> (cdr a) (cdr b))) ls) 53 | 10))))) 54 | 55 | (define (main) 56 | (let* ((count (read)) 57 | (input1 (read)) 58 | (output (read)) 59 | (s2 (number->string count)) 60 | (s1 input1) 61 | (name "bibfreq2")) 62 | (run-r6rs-benchmark 63 | (string-append name ":" s2) 64 | 1 65 | (lambda () (go (hide count input1))) 66 | (lambda (result) (equal? result output))))) 67 | -------------------------------------------------------------------------------- /etc/R7RS/src/cat.sch: -------------------------------------------------------------------------------- 1 | ;;; CAT -- One of the Kernighan and Van Wyk benchmarks. 2 | ;;; Rewritten by Will Clinger into more idiomatic Scheme. 3 | 4 | (import (scheme base) 5 | (scheme read) 6 | (scheme file) 7 | (scheme write)) 8 | 9 | (define (catport in out) 10 | (let ((x (read-char in))) 11 | (if (not (eof-object? x)) 12 | (begin 13 | (write-char x out) 14 | (catport in out))))) 15 | 16 | (define (go input-file output-file) 17 | (if (file-exists? output-file) 18 | (delete-file output-file)) 19 | (call-with-input-file 20 | input-file 21 | (lambda (in) 22 | (call-with-output-file 23 | output-file 24 | (lambda (out) 25 | (catport in out)))))) 26 | 27 | (define (main) 28 | (let* ((count (read)) 29 | (input1 (read)) 30 | (input2 (read)) 31 | (output (read)) 32 | (s3 (number->string count)) 33 | (s2 input2) 34 | (s1 input1) 35 | (name "cat")) 36 | (run-r7rs-benchmark 37 | (string-append name ":" s3) 38 | count 39 | (lambda () (go (hide count input1) (hide count input2))) 40 | (lambda (result) #t)))) 41 | 42 | (include "src/common.sch") 43 | -------------------------------------------------------------------------------- /etc/R7RS/src/cat2.sch: -------------------------------------------------------------------------------- 1 | ;;; CAT -- One of the Kernighan and Van Wyk benchmarks. 2 | ;;; Rewritten by Will Clinger into more idiomatic Scheme 3 | ;;; and to use UTF-8 transcoding. 4 | 5 | (import (rnrs base) 6 | (rnrs io ports) 7 | (rnrs io simple) 8 | (rnrs files)) 9 | 10 | (define (catport in out) 11 | (let ((x (get-char in))) 12 | (if (not (eof-object? x)) 13 | (begin 14 | (put-char out x) 15 | (catport in out))))) 16 | 17 | (define (go input-file output-file) 18 | (let ((t (make-transcoder (utf-8-codec)))) 19 | (if (file-exists? output-file) 20 | (delete-file output-file)) 21 | (call-with-port 22 | (open-file-input-port input-file (file-options) 'block t) 23 | (lambda (in) 24 | (call-with-port 25 | (open-file-output-port output-file (file-options) 'block t) 26 | (lambda (out) 27 | (catport in out))))))) 28 | 29 | (define (main) 30 | (let* ((count (read)) 31 | (input1 (read)) 32 | (input2 (read)) 33 | (output (read)) 34 | (s3 (number->string count)) 35 | (s2 input2) 36 | (s1 input1) 37 | (name "cat:utf-8")) 38 | (run-r6rs-benchmark 39 | (string-append name ":" s3) 40 | count 41 | (lambda () (go (hide count input1) (hide count input2))) 42 | (lambda (result) #t)))) 43 | -------------------------------------------------------------------------------- /etc/R7RS/src/cat3.sch: -------------------------------------------------------------------------------- 1 | ;;; CAT -- One of the Kernighan and Van Wyk benchmarks. 2 | ;;; Rewritten by Will Clinger into more idiomatic Scheme 3 | ;;; and to use UTF-16 transcoding. 4 | 5 | (import (rnrs base) 6 | (rnrs io ports) 7 | (rnrs io simple) 8 | (rnrs files)) 9 | 10 | (define (catport in out) 11 | (let ((x (get-char in))) 12 | (if (not (eof-object? x)) 13 | (begin 14 | (put-char out x) 15 | (catport in out))))) 16 | 17 | (define (go input-file output-file) 18 | (let ((t (make-transcoder (utf-16-codec)))) 19 | (if (file-exists? output-file) 20 | (delete-file output-file)) 21 | (call-with-port 22 | (open-file-input-port input-file (file-options) 'block t) 23 | (lambda (in) 24 | (call-with-port 25 | (open-file-output-port output-file (file-options) 'block t) 26 | (lambda (out) 27 | (catport in out))))))) 28 | 29 | (define (main) 30 | (let* ((count (read)) 31 | (input1 (read)) 32 | (input2 (read)) 33 | (output (read)) 34 | (s3 (number->string count)) 35 | (s2 input2) 36 | (s1 input1) 37 | (name "cat:utf-16")) 38 | (run-r6rs-benchmark 39 | (string-append name ":" s3) 40 | count 41 | (lambda () (go (hide count input1) (hide count input2))) 42 | (lambda (result) #t)))) 43 | -------------------------------------------------------------------------------- /etc/R7RS/src/common.sch: -------------------------------------------------------------------------------- 1 | 2 | ;;; The following code is appended to all benchmarks. 3 | 4 | ;;; Given an integer and an object, returns the object 5 | ;;; without making it too easy for compilers to tell 6 | ;;; the object will be returned. 7 | 8 | (define (hide r x) 9 | (call-with-values 10 | (lambda () 11 | (values (vector values (lambda (x) x)) 12 | (if (< r 100) 0 1))) 13 | (lambda (v i) 14 | ((vector-ref v i) x)))) 15 | 16 | ;;; Given the name of a benchmark, 17 | ;;; the number of times it should be executed, 18 | ;;; a thunk that runs the benchmark once, 19 | ;;; and a unary predicate that is true of the 20 | ;;; correct results the thunk may return, 21 | ;;; runs the benchmark for the number of specified iterations. 22 | ;;; 23 | ;;; Implementation-specific versions of this procedure may 24 | ;;; provide timings for the benchmark proper (without startup 25 | ;;; and compile time). 26 | 27 | (define (run-r7rs-benchmark name count thunk ok?) 28 | (display "Running ") 29 | (display name) 30 | (newline) 31 | (let loop ((i 0) 32 | (result (if #f #f))) 33 | (cond ((< i count) 34 | (loop (+ i 1) (thunk))) 35 | ((ok? result) 36 | result) 37 | (else 38 | (display "ERROR: returned incorrect result: ") 39 | (write result) 40 | (newline) 41 | result)))) 42 | 43 | (main) 44 | -------------------------------------------------------------------------------- /etc/R7RS/src/cpstak.sch: -------------------------------------------------------------------------------- 1 | ;;; CPSTAK -- A continuation-passing version of the TAK benchmark. 2 | ;;; A good test of first class procedures and tail recursion. 3 | 4 | (import (scheme base) 5 | (scheme read) 6 | (scheme write)) 7 | 8 | (define (cpstak x y z) 9 | 10 | (define (tak x y z k) 11 | (if (not (< y x)) 12 | (k z) 13 | (tak (- x 1) 14 | y 15 | z 16 | (lambda (v1) 17 | (tak (- y 1) 18 | z 19 | x 20 | (lambda (v2) 21 | (tak (- z 1) 22 | x 23 | y 24 | (lambda (v3) 25 | (tak v1 v2 v3 k))))))))) 26 | 27 | (tak x y z (lambda (a) a))) 28 | 29 | (define (main) 30 | (let* ((count (read)) 31 | (input1 (read)) 32 | (input2 (read)) 33 | (input3 (read)) 34 | (output (read)) 35 | (s4 (number->string count)) 36 | (s3 (number->string input3)) 37 | (s2 (number->string input2)) 38 | (s1 (number->string input1)) 39 | (name "cpstak")) 40 | (run-r7rs-benchmark 41 | (string-append name ":" s1 ":" s2 ":" s3 ":" s4) 42 | count 43 | (lambda () 44 | (cpstak (hide count input1) (hide count input2) (hide count input3))) 45 | (lambda (result) (equal? result output))))) 46 | 47 | (include "src/common.sch") 48 | -------------------------------------------------------------------------------- /etc/R7RS/src/ctak.sch: -------------------------------------------------------------------------------- 1 | ;;; CTAK -- A version of the TAK procedure that uses continuations. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (ctak x y z) 8 | (call-with-current-continuation 9 | (lambda (k) (ctak-aux k x y z)))) 10 | 11 | (define (ctak-aux k x y z) 12 | (if (not (< y x)) 13 | (k z) 14 | (call-with-current-continuation 15 | (lambda (k) 16 | (ctak-aux 17 | k 18 | (call-with-current-continuation 19 | (lambda (k) (ctak-aux k (- x 1) y z))) 20 | (call-with-current-continuation 21 | (lambda (k) (ctak-aux k (- y 1) z x))) 22 | (call-with-current-continuation 23 | (lambda (k) (ctak-aux k (- z 1) x y)))))))) 24 | 25 | (define (main) 26 | (let* ((count (read)) 27 | (input1 (read)) 28 | (input2 (read)) 29 | (input3 (read)) 30 | (output (read)) 31 | (s4 (number->string count)) 32 | (s3 (number->string input3)) 33 | (s2 (number->string input2)) 34 | (s1 (number->string input1)) 35 | (name "ctak")) 36 | (run-r7rs-benchmark 37 | (string-append name ":" s1 ":" s2 ":" s3 ":" s4) 38 | count 39 | (lambda () 40 | (ctak (hide count input1) (hide count input2) (hide count input3))) 41 | (lambda (result) (equal? result output))))) 42 | 43 | (include "src/common.sch") 44 | -------------------------------------------------------------------------------- /etc/R7RS/src/dderiv.sch: -------------------------------------------------------------------------------- 1 | ;;; DDERIV -- Table-driven symbolic derivation. 2 | 3 | ;;; Returns the wrong answer for quotients. 4 | ;;; Fortunately these aren't used in the benchmark. 5 | 6 | (import (rnrs base) 7 | (rnrs io simple) 8 | (rnrs hashtables) 9 | (rnrs mutable-pairs)) 10 | 11 | (define (lookup key table) 12 | (let loop ((x table)) 13 | (if (null? x) 14 | #f 15 | (let ((pair (car x))) 16 | (if (eq? (car pair) key) 17 | pair 18 | (loop (cdr x))))))) 19 | 20 | (define properties (make-hashtable symbol-hash eq?)) 21 | 22 | (define (get key1 key2) 23 | (let ((x (hashtable-ref properties key1 #f))) 24 | (if x 25 | (let ((y (lookup key2 x))) 26 | (if y 27 | (cdr y) 28 | #f)) 29 | #f))) 30 | 31 | (define (put key1 key2 val) 32 | (let ((x (hashtable-ref properties key1 #f))) 33 | (if x 34 | (let ((y (lookup key2 x))) 35 | (if y 36 | (set-cdr! y val) 37 | (set-cdr! x (cons (cons key2 val) (cdr x))))) 38 | (hashtable-set! properties key1 (list (cons key2 val)))))) 39 | 40 | (define (my+dderiv a) 41 | (cons '+ 42 | (map dderiv (cdr a)))) 43 | 44 | (define (my-dderiv a) 45 | (cons '- 46 | (map dderiv (cdr a)))) 47 | 48 | (define (*dderiv a) 49 | (list '* 50 | a 51 | (cons '+ 52 | (map (lambda (a) (list '/ (dderiv a) a)) (cdr a))))) 53 | 54 | (define (/dderiv a) 55 | (list '- 56 | (list '/ 57 | (dderiv (cadr a)) 58 | (caddr a)) 59 | (list '/ 60 | (cadr a) 61 | (list '* 62 | (caddr a) 63 | (caddr a) 64 | (dderiv (caddr a)))))) 65 | 66 | (put '+ 'dderiv my+dderiv) 67 | (put '- 'dderiv my-dderiv) 68 | (put '* 'dderiv *dderiv) 69 | (put '/ 'dderiv /dderiv) 70 | 71 | (define (dderiv a) 72 | (if (not (pair? a)) 73 | (if (eq? a 'x) 1 0) 74 | (let ((f (get (car a) 'dderiv))) 75 | (if f 76 | (f a) 77 | (error #f "No derivation method available"))))) 78 | 79 | (define (main) 80 | (let* ((count (read)) 81 | (input1 (read)) 82 | (output (read)) 83 | (s (number->string count)) 84 | (name "dderiv")) 85 | (run-r6rs-benchmark 86 | (string-append name ":" s) 87 | count 88 | (lambda () (dderiv (hide count input1))) 89 | (lambda (result) (equal? result output))))) 90 | 91 | 92 | -------------------------------------------------------------------------------- /etc/R7RS/src/deriv.sch: -------------------------------------------------------------------------------- 1 | ;;; DERIV -- Symbolic derivation. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write) 6 | (scheme cxr)) 7 | 8 | ;;; Returns the wrong answer for quotients. 9 | ;;; Fortunately these aren't used in the benchmark. 10 | 11 | (define (deriv a) 12 | (cond ((not (pair? a)) 13 | (if (eq? a 'x) 1 0)) 14 | ((eq? (car a) '+) 15 | (cons '+ 16 | (map deriv (cdr a)))) 17 | ((eq? (car a) '-) 18 | (cons '- 19 | (map deriv (cdr a)))) 20 | ((eq? (car a) '*) 21 | (list '* 22 | a 23 | (cons '+ 24 | (map (lambda (a) (list '/ (deriv a) a)) (cdr a))))) 25 | ((eq? (car a) '/) 26 | (list '- 27 | (list '/ 28 | (deriv (cadr a)) 29 | (caddr a)) 30 | (list '/ 31 | (cadr a) 32 | (list '* 33 | (caddr a) 34 | (caddr a) 35 | (deriv (caddr a)))))) 36 | (else 37 | (error #f "No derivation method available")))) 38 | 39 | (define (main) 40 | (let* ((count (read)) 41 | (input1 (read)) 42 | (output (read)) 43 | (s (number->string count)) 44 | (name "deriv")) 45 | (run-r7rs-benchmark 46 | (string-append name ":" s) 47 | count 48 | (lambda () (deriv (hide count input1))) 49 | (lambda (result) (equal? result output))))) 50 | 51 | (include "src/common.sch") 52 | -------------------------------------------------------------------------------- /etc/R7RS/src/destruc.sch: -------------------------------------------------------------------------------- 1 | ;;; DESTRUC -- Destructive operation benchmark. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define div quotient) 8 | 9 | (define (append-to-tail! x y) 10 | (if (null? x) 11 | y 12 | (let loop ((a x) (b (cdr x))) 13 | (if (null? b) 14 | (begin 15 | (set-cdr! a y) 16 | x) 17 | (loop b (cdr b)))))) 18 | 19 | (define (destructive n m) 20 | (let ((l (do ((i 10 (- i 1)) (a '() (cons '() a))) 21 | ((= i 0) a)))) 22 | (do ((i n (- i 1))) 23 | ((= i 0) l) 24 | (cond ((null? (car l)) 25 | (do ((l l (cdr l))) 26 | ((null? l)) 27 | (if (null? (car l)) (set-car! l (cons '() '()))) 28 | (append-to-tail! (car l) 29 | (do ((j m (- j 1)) (a '() (cons '() a))) 30 | ((= j 0) a))))) 31 | (else 32 | (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) 33 | ((null? l2)) 34 | (set-cdr! (do ((j (div (length (car l2)) 2) (- j 1)) 35 | (a (car l2) (cdr a))) 36 | ((zero? j) a) 37 | (set-car! a i)) 38 | (let ((n (div (length (car l1)) 2))) 39 | (cond ((= n 0) 40 | (set-car! l1 '()) 41 | (car l1)) 42 | (else 43 | (do ((j n (- j 1)) (a (car l1) (cdr a))) 44 | ((= j 1) 45 | (let ((x (cdr a))) 46 | (set-cdr! a '()) 47 | x)) 48 | (set-car! a i)))))))))))) 49 | 50 | (define (main) 51 | (let* ((count (read)) 52 | (input1 (read)) 53 | (input2 (read)) 54 | (output (read)) 55 | (s3 (number->string count)) 56 | (s2 (number->string input2)) 57 | (s1 (number->string input1)) 58 | (name "destruc")) 59 | (run-r7rs-benchmark 60 | (string-append name ":" s1 ":" s2 ":" s3) 61 | count 62 | (lambda () 63 | (destructive (hide count input1) (hide count input2))) 64 | (lambda (result) (equal? result output))))) 65 | 66 | (include "src/common.sch") 67 | -------------------------------------------------------------------------------- /etc/R7RS/src/diviter.sch: -------------------------------------------------------------------------------- 1 | ;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (create-n n) 8 | (do ((n n (- n 1)) 9 | (a '() (cons '() a))) 10 | ((= n 0) a))) 11 | 12 | (define (iterative-div2 l) 13 | (do ((l l (cddr l)) 14 | (a '() (cons (car l) a))) 15 | ((null? l) a))) 16 | 17 | (define (main) 18 | (let* ((count (read)) 19 | (input1 (read)) 20 | (output (read)) 21 | (s2 (number->string count)) 22 | (s1 (number->string input1)) 23 | (ll (create-n (hide count input1))) 24 | (name "diviter")) 25 | (run-r7rs-benchmark 26 | (string-append name ":" s1 ":" s2) 27 | count 28 | (lambda () 29 | (iterative-div2 ll)) 30 | (lambda (result) (equal? (length result) output))))) 31 | 32 | (include "src/common.sch") 33 | -------------------------------------------------------------------------------- /etc/R7RS/src/divrec.sch: -------------------------------------------------------------------------------- 1 | ;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (create-n n) 8 | (do ((n n (- n 1)) 9 | (a '() (cons '() a))) 10 | ((= n 0) a))) 11 | 12 | (define (recursive-div2 l) 13 | (cond ((null? l) '()) 14 | (else (cons (car l) (recursive-div2 (cddr l)))))) 15 | 16 | (define (main) 17 | (let* ((count (read)) 18 | (input1 (read)) 19 | (output (read)) 20 | (s2 (number->string count)) 21 | (s1 (number->string input1)) 22 | (ll (create-n (hide count input1))) 23 | (name "divrec")) 24 | (run-r7rs-benchmark 25 | (string-append name ":" s1 ":" s2) 26 | count 27 | (lambda () 28 | (recursive-div2 ll)) 29 | (lambda (result) (equal? (length result) output))))) 30 | 31 | (include "src/common.sch") 32 | -------------------------------------------------------------------------------- /etc/R7RS/src/fft.sch: -------------------------------------------------------------------------------- 1 | ;;; FFT - Fast Fourier Transform, translated from "Numerical Recipes in C" 2 | 3 | (import (scheme base) 4 | (scheme inexact) 5 | (scheme write) 6 | (scheme read)) 7 | 8 | (define div quotient) 9 | 10 | (define (four1 data) 11 | (let ((n (vector-length data)) 12 | (pi*2 6.28318530717959)) ; to compute the inverse, negate this value 13 | 14 | ; bit-reversal section 15 | 16 | (let loop1 ((i 0) (j 0)) 17 | (if (< i n) 18 | (begin 19 | (if (< i j) 20 | (begin 21 | (let ((temp (vector-ref data i))) 22 | (vector-set! data i (vector-ref data j)) 23 | (vector-set! data j temp)) 24 | (let ((temp (vector-ref data (+ i 1)))) 25 | (vector-set! data (+ i 1) (vector-ref data (+ j 1))) 26 | (vector-set! data (+ j 1) temp)))) 27 | (let loop2 ((m (div n 2)) (j j)) 28 | (if (and (>= m 2) (>= j m)) 29 | (loop2 (div m 2) (- j m)) 30 | (loop1 (+ i 2) (+ j m))))))) 31 | 32 | ; Danielson-Lanczos section 33 | 34 | (let loop3 ((mmax 2)) 35 | (if (< mmax n) 36 | (let* ((theta 37 | (/ pi*2 (inexact mmax))) 38 | (wpr 39 | (let ((x (sin (* 0.5 theta)))) 40 | (* -2.0 (* x x)))) 41 | (wpi 42 | (sin theta))) 43 | (let loop4 ((wr 1.0) (wi 0.0) (m 0)) 44 | (if (< m mmax) 45 | (begin 46 | (let loop5 ((i m)) 47 | (if (< i n) 48 | (let* ((j 49 | (+ i mmax)) 50 | (tempr 51 | (- 52 | (* wr (vector-ref data j)) 53 | (* wi (vector-ref data (+ j 1))))) 54 | (tempi 55 | (+ 56 | (* wr (vector-ref data (+ j 1))) 57 | (* wi (vector-ref data j))))) 58 | (vector-set! data j 59 | (- (vector-ref data i) tempr)) 60 | (vector-set! data (+ j 1) 61 | (- (vector-ref data (+ i 1)) tempi)) 62 | (vector-set! data i 63 | (+ (vector-ref data i) tempr)) 64 | (vector-set! data (+ i 1) 65 | (+ (vector-ref data (+ i 1)) tempi)) 66 | (loop5 (+ j mmax)));***)) 67 | (loop4 (+ (- (* wr wpr) (* wi wpi)) wr) 68 | (+ (+ (* wi wpr) (* wr wpi)) wi) 69 | (+ m 2))))) 70 | ));****** 71 | (loop3 (* mmax 2))))))) 72 | 73 | (define data 74 | (make-vector 1024 0.0)) 75 | 76 | (define (run data) 77 | (four1 data) 78 | (vector-ref data 0)) 79 | 80 | (define (main) 81 | (let* ((count (read)) 82 | (input1 (read)) 83 | (input2 (read)) 84 | (output (read)) 85 | (s2 (number->string count)) 86 | (s1 (number->string input1)) 87 | (name "fft")) 88 | (run-r7rs-benchmark 89 | (string-append name ":" s1 ":" s2) 90 | count 91 | (lambda () 92 | (run (hide count (make-vector input1 input2)))) 93 | (lambda (result) (equal? result output))))) 94 | 95 | (include "src/common.sch") 96 | -------------------------------------------------------------------------------- /etc/R7RS/src/fib.sch: -------------------------------------------------------------------------------- 1 | ;;; FIB -- A classic benchmark, computes fib(n) inefficiently. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (fib n) 8 | (if (< n 2) 9 | n 10 | (+ (fib (- n 1)) 11 | (fib (- n 2))))) 12 | 13 | (define (main) 14 | (let* ((count (read)) 15 | (input (read)) 16 | (output (read)) 17 | (s2 (number->string count)) 18 | (s1 (number->string input)) 19 | (name "fib")) 20 | (run-r7rs-benchmark 21 | (string-append name ":" s1 ":" s2) 22 | count 23 | (lambda () (fib (hide count input))) 24 | (lambda (result) (= result output))))) 25 | 26 | (include "src/common.sch") 27 | -------------------------------------------------------------------------------- /etc/R7RS/src/fibc.sch: -------------------------------------------------------------------------------- 1 | ;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (succ n) (+ n 1)) 8 | (define (pred n) (- n 1)) 9 | 10 | ;;; fib with peano arithmetic (using numbers) with call/cc 11 | 12 | (define (addc x y k) 13 | (if (zero? y) 14 | (k x) 15 | (addc (succ x) (pred y) k))) 16 | 17 | (define (fibc x c) 18 | (if (zero? x) 19 | (c 0) 20 | (if (zero? (pred x)) 21 | (c 1) 22 | (addc (call-with-current-continuation 23 | (lambda (c) (fibc (pred x) c))) 24 | (call-with-current-continuation 25 | (lambda (c) (fibc (pred (pred x)) c))) 26 | c)))) 27 | 28 | (define (main) 29 | (let* ((count (read)) 30 | (input (read)) 31 | (output (read)) 32 | (s2 (number->string count)) 33 | (s1 (number->string input)) 34 | (name "fibc")) 35 | (run-r7rs-benchmark 36 | (string-append name ":" s1 ":" s2) 37 | count 38 | (lambda () (fibc (hide count input) (hide count (lambda (n) n)))) 39 | (lambda (result) (= result output))))) 40 | 41 | (include "src/common.sch") 42 | -------------------------------------------------------------------------------- /etc/R7RS/src/fibfp.sch: -------------------------------------------------------------------------------- 1 | ;;; FIBFP -- Computes fib(35) using floating point 2 | 3 | (import (rnrs base) 4 | (rnrs io simple) 5 | (rnrs arithmetic flonums)) 6 | 7 | (define (fibfp n) 8 | (if (flstring count)) 18 | (s1 (number->string input)) 19 | (name "fibfp")) 20 | (run-r6rs-benchmark 21 | (string-append name ":" s1 ":" s2) 22 | count 23 | (lambda () (fibfp (hide count input))) 24 | (lambda (result) (= result output))))) 25 | 26 | -------------------------------------------------------------------------------- /etc/R7RS/src/listsort.sch: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; 3 | ; Copyright 2007 William D Clinger. 4 | ; 5 | ; Permission to copy this software, in whole or in part, to use this 6 | ; software for any lawful purpose, and to redistribute this software 7 | ; is granted subject to the restriction that all copies made of this 8 | ; software must include this copyright notice in full. 9 | ; 10 | ; I also request that you send me a copy of any improvements that you 11 | ; make to this software so that they may be incorporated within it to 12 | ; the benefit of the Scheme community. 13 | ; 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | ; 16 | ; List sorting benchmark. 17 | ; 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | 20 | (import (rnrs base) 21 | (rnrs sorting) 22 | (rnrs control) 23 | (rnrs io simple) 24 | (rnrs arithmetic fixnums)) 25 | 26 | ; Returns a list of all Unicode characters from lo to hi, 27 | ; inclusive. 28 | 29 | (define (all-characters lo hi) 30 | (define (loop sv0 sv1 chars) 31 | (cond ((fxchar sv1) chars))) 36 | (else 37 | (loop sv0 #xd7ff chars)))) 38 | (loop (char->integer lo) (char->integer hi) '())) 39 | 40 | (define (hashinteger c))) 43 | (fx- sv (fxxor sv (fxarithmetic-shift-right sv 2))))) 44 | (fxstring count)) 56 | (s2 (number->string input2)) 57 | (s1 (number->string input1)) 58 | (name "listsort") 59 | (chars 60 | (hide count 61 | (all-characters 62 | (integer->char input1) (integer->char input2))))) 63 | (run-r6rs-benchmark 64 | (string-append name ":" s1 ":" s2 ":" s3) 65 | count 66 | (lambda () (hash-then-sort chars)) 67 | (lambda (result) (equal? result chars))))) 68 | -------------------------------------------------------------------------------- /etc/R7RS/src/mbrot.sch: -------------------------------------------------------------------------------- 1 | ;;; MBROT -- Generation of Mandelbrot set fractal. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (count r i step x y) 8 | 9 | (let ((max-count 64) 10 | (radius^2 16.0)) 11 | 12 | (let ((cr (+ r (* (inexact x) step))) 13 | (ci (+ i (* (inexact y) step)))) 14 | 15 | (let loop ((zr cr) 16 | (zi ci) 17 | (c 0)) 18 | (if (= c max-count) 19 | c 20 | (let ((zr^2 (* zr zr)) 21 | (zi^2 (* zi zi))) 22 | (if (> (+ zr^2 zi^2) radius^2) 23 | c 24 | (let ((new-zr (+ (- zr^2 zi^2) cr)) 25 | (new-zi (+ (* 2.0 (* zr zi)) ci))) 26 | (loop new-zr new-zi (+ c 1)))))))))) 27 | 28 | (define (mbrot matrix r i step n) 29 | (let loop1 ((y (- n 1))) 30 | (if (>= y 0) 31 | (let loop2 ((x (- n 1))) 32 | (if (>= x 0) 33 | (begin 34 | (vector-set! (vector-ref matrix x) y (count r i step x y)) 35 | (loop2 (- x 1))) 36 | (loop1 (- y 1))))))) 37 | 38 | (define (test n) 39 | (let ((matrix (make-vector n))) 40 | (let loop ((i (- n 1))) 41 | (if (>= i 0) 42 | (begin 43 | (vector-set! matrix i (make-vector n)) 44 | (loop (- i 1))))) 45 | (mbrot matrix -1.0 -0.5 0.005 n) 46 | (vector-ref (vector-ref matrix 0) 0))) 47 | 48 | (define (main) 49 | (let* ((count (read)) 50 | (input1 (read)) 51 | (output (read)) 52 | (s2 (number->string count)) 53 | (s1 (number->string input1)) 54 | (name "mbrot")) 55 | (run-r7rs-benchmark 56 | (string-append name ":" s1 ":" s2) 57 | count 58 | (lambda () (test (hide count input1))) 59 | (lambda (result) (= result output))))) 60 | 61 | (include "src/common.sch") 62 | -------------------------------------------------------------------------------- /etc/R7RS/src/mbrotZ.sch: -------------------------------------------------------------------------------- 1 | ;;; MBROT -- Generation of Mandelbrot set fractal 2 | ;;; using Scheme's complex numbers. 3 | 4 | (import (scheme base) 5 | (scheme read) 6 | (scheme write) 7 | (scheme complex)) 8 | 9 | (define (count z0 step z) 10 | 11 | (let* ((max-count 64) 12 | (radius 4.0) 13 | (radius^2 (* radius radius))) 14 | 15 | (let ((z0 (+ z0 (* z step)))) 16 | 17 | (let loop ((z z0) 18 | (c 0)) 19 | (if (= c max-count) 20 | c 21 | (let* ((zr (real-part z)) 22 | (zi (imag-part z)) 23 | (zr^2 (* zr zr)) 24 | (zi^2 (* zi zi))) 25 | (if (> (+ zr^2 zi^2) radius^2) 26 | c 27 | (loop (+ (* z z) z0) (+ c 1))))))))) 28 | 29 | (define (mbrot matrix z0 step n) 30 | (let loop1 ((y (- n 1))) 31 | (if (>= y 0) 32 | (let loop2 ((x (- n 1))) 33 | (if (>= x 0) 34 | (begin 35 | (vector-set! (vector-ref matrix x) 36 | y 37 | (count z0 38 | step 39 | (make-rectangular (inexact x) 40 | (inexact y)))) 41 | (loop2 (- x 1))) 42 | (loop1 (- y 1))))))) 43 | 44 | (define (test n) 45 | (let ((matrix (make-vector n))) 46 | (let loop ((i (- n 1))) 47 | (if (>= i 0) 48 | (begin 49 | (vector-set! matrix i (make-vector n)) 50 | (loop (- i 1))))) 51 | (mbrot matrix -1.0-0.5i 0.005 n) 52 | (vector-ref (vector-ref matrix 0) 0))) 53 | 54 | (define (main) 55 | (let* ((count (read)) 56 | (input1 (read)) 57 | (output (read)) 58 | (s2 (number->string count)) 59 | (s1 (number->string input1)) 60 | (name "mbrotZ")) 61 | (run-r7rs-benchmark 62 | (string-append name ":" s1 ":" s2) 63 | count 64 | (lambda () (test (hide count input1))) 65 | (lambda (result) (= result output))))) 66 | 67 | (include "src/common.sch") 68 | -------------------------------------------------------------------------------- /etc/R7RS/src/nqueens.sch: -------------------------------------------------------------------------------- 1 | ;;; NQUEENS -- Compute number of solutions to 8-queens problem. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define trace? #f) 8 | 9 | (define (nqueens n) 10 | 11 | (define (iota1 n) 12 | (let loop ((i n) (l '())) 13 | (if (= i 0) l (loop (- i 1) (cons i l))))) 14 | 15 | (define (my-try x y z) 16 | (if (null? x) 17 | (if (null? y) 18 | (begin (if trace? (begin (write z) (newline))) 1) 19 | 0) 20 | (+ (if (ok? (car x) 1 z) 21 | (my-try (append (cdr x) y) '() (cons (car x) z)) 22 | 0) 23 | (my-try (cdr x) (cons (car x) y) z)))) 24 | 25 | (define (ok? row dist placed) 26 | (if (null? placed) 27 | #t 28 | (and (not (= (car placed) (+ row dist))) 29 | (not (= (car placed) (- row dist))) 30 | (ok? row (+ dist 1) (cdr placed))))) 31 | 32 | (my-try (iota1 n) '() '())) 33 | 34 | (define (main) 35 | (let* ((count (read)) 36 | (input1 (read)) 37 | (output (read)) 38 | (s2 (number->string count)) 39 | (s1 (number->string input1)) 40 | (name "nqueens")) 41 | (run-r7rs-benchmark 42 | (string-append name ":" s1 ":" s2) 43 | count 44 | (lambda () (nqueens (hide count input1))) 45 | (lambda (result) (= result output))))) 46 | 47 | (include "src/common.sch") 48 | -------------------------------------------------------------------------------- /etc/R7RS/src/ntakl.sch: -------------------------------------------------------------------------------- 1 | ;;; NTAKL -- The TAKeuchi function using lists as counters, 2 | ;;; with an alternative boolean expression. 3 | 4 | (import (scheme base) 5 | (scheme read) 6 | (scheme write)) 7 | 8 | (define (listn n) 9 | (if (= n 0) 10 | '() 11 | (cons n (listn (- n 1))))) 12 | 13 | (define l18 (listn 18)) 14 | (define l12 (listn 12)) 15 | (define l6 (listn 6)) 16 | 17 | (define (mas x y z) 18 | (if (not (shorterp y x)) 19 | z 20 | (mas (mas (cdr x) y z) 21 | (mas (cdr y) z x) 22 | (mas (cdr z) x y)))) 23 | 24 | ; Part of the fun of this benchmark is seeing how well the compiler 25 | ; can understand this ridiculous code, which dates back to the original 26 | ; Common Lisp. So it probably isn't a good idea to improve upon it. 27 | 28 | #; 29 | (define (shorterp x y) 30 | (and (not (null? y)) 31 | (or (null? x) 32 | (shorterp (cdr x) 33 | (cdr y))))) 34 | 35 | ; But SML/NJ runs this benchmark about 15 times as fast when the 36 | ; code above is rewritten as follows, so I tried it for Scheme also. 37 | 38 | (define (shorterp x y) 39 | (cond ((null? y) #f) 40 | ((null? x) #t) 41 | (else 42 | (shorterp (cdr x) (cdr y))))) 43 | 44 | (define (main) 45 | (let* ((count (read)) 46 | (input1 (read)) 47 | (input2 (read)) 48 | (input3 (read)) 49 | (output (read)) 50 | (s4 (number->string count)) 51 | (s3 (number->string (length input3))) 52 | (s2 (number->string (length input2))) 53 | (s1 (number->string (length input1))) 54 | (name "ntakl")) 55 | (run-r7rs-benchmark 56 | (string-append name ":" s1 ":" s2 ":" s3 ":" s4) 57 | count 58 | (lambda () 59 | (mas (hide count input1) (hide count input2) (hide count input3))) 60 | (lambda (result) (equal? (length result) output))))) 61 | 62 | (include "src/common.sch") 63 | -------------------------------------------------------------------------------- /etc/R7RS/src/pnpoly.sch: -------------------------------------------------------------------------------- 1 | ;;; PNPOLY - Test if a point is contained in a 2D polygon. 2 | 3 | (import (scheme base) 4 | (scheme write) 5 | (scheme read)) 6 | 7 | (define (pt-in-poly2 xp yp x y) 8 | (let loop ((c #f) (i (- (vector-length xp) 1)) (j 0)) 9 | (if (< i 0) 10 | c 11 | (if (or (and (or (> (vector-ref yp i) y) 12 | (>= y (vector-ref yp j))) 13 | (or (> (vector-ref yp j) y) 14 | (>= y (vector-ref yp i)))) 15 | (>= x 16 | (+ (vector-ref xp i) 17 | (/ (* 18 | (- (vector-ref xp j) 19 | (vector-ref xp i)) 20 | (- y (vector-ref yp i))) 21 | (- (vector-ref yp j) 22 | (vector-ref yp i)))))) 23 | (loop c (- i 1) i) 24 | (loop (not c) (- i 1) i))))) 25 | 26 | (define (run input1 input2) 27 | (let ((count 0) 28 | (xp (list->vector (vector->list input1))) 29 | (yp (list->vector (vector->list input2)))) 30 | (if (pt-in-poly2 xp yp .5 .5) (set! count (+ count 1))) 31 | (if (pt-in-poly2 xp yp .5 1.5) (set! count (+ count 1))) 32 | (if (pt-in-poly2 xp yp -.5 1.5) (set! count (+ count 1))) 33 | (if (pt-in-poly2 xp yp .75 2.25) (set! count (+ count 1))) 34 | (if (pt-in-poly2 xp yp 0. 2.01) (set! count (+ count 1))) 35 | (if (pt-in-poly2 xp yp -.5 2.5) (set! count (+ count 1))) 36 | (if (pt-in-poly2 xp yp -1. -.5) (set! count (+ count 1))) 37 | (if (pt-in-poly2 xp yp -1.5 .5) (set! count (+ count 1))) 38 | (if (pt-in-poly2 xp yp -2.25 -1.) (set! count (+ count 1))) 39 | (if (pt-in-poly2 xp yp .5 -.25) (set! count (+ count 1))) 40 | (if (pt-in-poly2 xp yp .5 -1.25) (set! count (+ count 1))) 41 | (if (pt-in-poly2 xp yp -.5 -2.5) (set! count (+ count 1))) 42 | count)) 43 | 44 | (define (main) 45 | (let* ((count (read)) 46 | (input1 (read)) 47 | (input2 (read)) 48 | (output (read)) 49 | (s2 (number->string count)) 50 | (s1 "") 51 | (name "pnpoly")) 52 | (run-r7rs-benchmark 53 | (string-append name ":" s2) 54 | count 55 | (lambda () (run (hide count input1) (hide count input2))) 56 | (lambda (result) (and (number? result) (= result output)))))) 57 | 58 | (include "src/common.sch") 59 | -------------------------------------------------------------------------------- /etc/R7RS/src/primes.sch: -------------------------------------------------------------------------------- 1 | ;;; PRIMES -- Compute primes less than 100, written by Eric Mohr. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define div quotient) 8 | (define mod modulo) 9 | 10 | (define (interval-list m n) 11 | (if (> m n) 12 | '() 13 | (cons m (interval-list (+ 1 m) n)))) 14 | 15 | (define (sieve l) 16 | (letrec ((remove-multiples 17 | (lambda (n l) 18 | (if (null? l) 19 | '() 20 | (if (= (mod (car l) n) 0) 21 | (remove-multiples n (cdr l)) 22 | (cons (car l) 23 | (remove-multiples n (cdr l)))))))) 24 | (if (null? l) 25 | '() 26 | (cons (car l) 27 | (sieve (remove-multiples (car l) (cdr l))))))) 28 | 29 | (define (primes<= n) 30 | (sieve (interval-list 2 n))) 31 | 32 | (define (main) 33 | (let* ((count (read)) 34 | (input1 (read)) 35 | (output (read)) 36 | (s2 (number->string count)) 37 | (s1 (number->string input1)) 38 | (name "primes")) 39 | (run-r7rs-benchmark 40 | (string-append name ":" s1 ":" s2) 41 | count 42 | (lambda () (primes<= (hide count input1))) 43 | (lambda (result) (equal? result output))))) 44 | 45 | (include "src/common.sch") 46 | -------------------------------------------------------------------------------- /etc/R7RS/src/read1.sch: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; 3 | ;;; Test of R6RS get-datum, comparable to the parsing benchmark. 4 | ;;; 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (import (scheme base) 8 | (scheme read) 9 | (scheme write) 10 | (scheme file)) 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ; 14 | ; get-datum benchmark comparable to the parsing benchmark. 15 | ; 16 | ; Reads nboyer.sch into a string before timing begins. 17 | ; 18 | ; The timed portion of the benchmark parses the string 19 | ; representation of nboyer.sch 1000 times. 20 | ; 21 | ; The output of that parse is checked by comparing it 22 | ; the the value returned by the read procedure. 23 | ; 24 | ; Usage: 25 | ; (read-benchmark n input) 26 | ; (read-from-string-port-benchmark n input) 27 | ; 28 | ; 29 | ; n defaults to 1000, and input defaults to "nboyer.sch". 30 | ; 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (read-from-file-benchmark input) 34 | (call-with-port 35 | (open-input-file input) 36 | (lambda (in) 37 | (do ((x (read in) (read in)) 38 | (y #f x) 39 | (i 0 (+ i 1))) 40 | ((eof-object? x) y))))) 41 | 42 | (define (main) 43 | (let* ((count (read)) 44 | (input1 (read)) 45 | (output (read)) 46 | (s2 (number->string count)) 47 | (name "read1:latin-1")) 48 | (run-r7rs-benchmark 49 | (string-append name ":" s2) 50 | count 51 | (lambda () (read-from-file-benchmark (hide count input1))) 52 | (lambda (result) (equal? result output))))) 53 | 54 | (include "src/common.sch") 55 | -------------------------------------------------------------------------------- /etc/R7RS/src/read2.sch: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; 3 | ;;; Test of R6RS get-datum, comparable to the parsing benchmark. 4 | ;;; 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (import (rnrs base) 8 | (rnrs control) 9 | (rnrs io ports) 10 | (rnrs io simple)) 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ; 14 | ; get-datum benchmark comparable to the parsing benchmark. 15 | ; 16 | ; Reads nboyer.sch into a string before timing begins. 17 | ; 18 | ; The timed portion of the benchmark parses the string 19 | ; representation of nboyer.sch 1000 times. 20 | ; 21 | ; The output of that parse is checked by comparing it 22 | ; the the value returned by the read procedure. 23 | ; 24 | ; Usage: 25 | ; (read-benchmark n input) 26 | ; (read-from-string-port-benchmark n input) 27 | ; 28 | ; 29 | ; n defaults to 1000, and input defaults to "nboyer.sch". 30 | ; 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (read-from-file-benchmark input t) 34 | (call-with-port 35 | (open-file-input-port input (file-options) 'block t) 36 | (lambda (in) 37 | (do ((x (read in) (read in)) 38 | (y #f x) 39 | (i 0 (+ i 1))) 40 | ((eof-object? x) y))))) 41 | 42 | (define (main) 43 | (let* ((count (read)) 44 | (input1 (read)) 45 | (output (read)) 46 | (s2 (number->string count)) 47 | (s1 input1) 48 | (name "read1:utf-8") 49 | (t (make-transcoder (utf-8-codec)))) 50 | (run-r6rs-benchmark 51 | (string-append name ":" s2) 52 | count 53 | (lambda () (read-from-file-benchmark (hide count input1) t)) 54 | (lambda (result) (equal? result output))))) 55 | -------------------------------------------------------------------------------- /etc/R7RS/src/read3.sch: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; 3 | ;;; Test of R6RS get-datum, comparable to the parsing benchmark. 4 | ;;; 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (import (rnrs base) 8 | (rnrs control) 9 | (rnrs io ports) 10 | (rnrs io simple)) 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ; 14 | ; get-datum benchmark comparable to the parsing benchmark. 15 | ; 16 | ; Reads nboyer.sch into a string before timing begins. 17 | ; 18 | ; The timed portion of the benchmark parses the string 19 | ; representation of nboyer.sch 1000 times. 20 | ; 21 | ; The output of that parse is checked by comparing it 22 | ; the the value returned by the read procedure. 23 | ; 24 | ; Usage: 25 | ; (read-benchmark n input) 26 | ; (read-from-string-port-benchmark n input) 27 | ; 28 | ; 29 | ; n defaults to 1000, and input defaults to "nboyer.sch". 30 | ; 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (read-from-file-benchmark input t) 34 | (call-with-port 35 | (open-file-input-port input (file-options) 'block t) 36 | (lambda (in) 37 | (do ((x (read in) (read in)) 38 | (y #f x) 39 | (i 0 (+ i 1))) 40 | ((eof-object? x) y))))) 41 | 42 | (define (main) 43 | (let* ((count (read)) 44 | (input1 (read)) 45 | (output (read)) 46 | (s2 (number->string count)) 47 | (s1 input1) 48 | (name "read1:utf-16") 49 | (t (make-transcoder (utf-16-codec)))) 50 | (run-r6rs-benchmark 51 | (string-append name ":" s2) 52 | count 53 | (lambda () (read-from-file-benchmark (hide count input1) t)) 54 | (lambda (result) (equal? result output))))) 55 | -------------------------------------------------------------------------------- /etc/R7RS/src/string.sch: -------------------------------------------------------------------------------- 1 | ;;; STRING -- One of the Kernighan and Van Wyk benchmarks. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define div quotient) 8 | 9 | (define s "abcdef") 10 | 11 | (define (grow) 12 | (set! s (string-append "123" s "456" s "789")) 13 | (set! s (string-append 14 | (substring s (div (string-length s) 2) (string-length s)) 15 | (substring s 0 (+ 1 (div (string-length s) 2))))) 16 | s) 17 | 18 | (define (trial n) 19 | (do ((i 0 (+ i 1))) 20 | ((> (string-length s) n) (string-length s)) 21 | (grow))) 22 | 23 | (define (my-try n) 24 | (do ((i 0 (+ i 1))) 25 | ((>= i 10) (string-length s)) 26 | (set! s "abcdef") 27 | (trial n))) 28 | 29 | (define (main) 30 | (let* ((count (read)) 31 | (input1 (read)) 32 | (output (read)) 33 | (s2 (number->string count)) 34 | (s1 (number->string input1)) 35 | (name "string")) 36 | (run-r7rs-benchmark 37 | (string-append name ":" s1 ":" s2) 38 | count 39 | (lambda () (my-try (hide count input1))) 40 | (lambda (result) (equal? result output))))) 41 | 42 | (include "src/common.sch") 43 | -------------------------------------------------------------------------------- /etc/R7RS/src/sum.sch: -------------------------------------------------------------------------------- 1 | ;;; SUM -- Compute sum of integers from 0 to 10000 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (run n) 8 | (let loop ((i n) (sum 0)) 9 | (if (< i 0) 10 | sum 11 | (loop (- i 1) (+ i sum))))) 12 | 13 | (define (main) 14 | (let* ((count (read)) 15 | (input1 (read)) 16 | (output (read)) 17 | (s2 (number->string count)) 18 | (s1 (number->string input1)) 19 | (name "sum")) 20 | (run-r7rs-benchmark 21 | (string-append name ":" s1 ":" s2) 22 | count 23 | (lambda () (run (hide count input1))) 24 | (lambda (result) (equal? result output))))) 25 | 26 | (include "src/common.sch") 27 | -------------------------------------------------------------------------------- /etc/R7RS/src/sum1.sch: -------------------------------------------------------------------------------- 1 | ;;; SUM1 -- One of the Kernighan and Van Wyk benchmarks. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write) 6 | (scheme file) 7 | (scheme inexact)) 8 | 9 | (define (sumport port sum-so-far) 10 | (let ((x (read port))) 11 | (if (eof-object? x) 12 | sum-so-far 13 | (sumport port (+ x sum-so-far))))) 14 | 15 | (define (sum port) 16 | (sumport port 0.0)) 17 | 18 | (define (go input) 19 | (call-with-input-file input sum)) 20 | 21 | (define (main) 22 | (let* ((count (read)) 23 | (input1 (read)) 24 | (output (read)) 25 | (s2 (number->string count)) 26 | (s1 input1) 27 | (name "sum1")) 28 | (run-r7rs-benchmark 29 | (string-append name ":" s2) 30 | count 31 | (lambda () (go (hide count input1))) 32 | (lambda (result) (<= (abs (- result output)) 1e-9))))) 33 | 34 | (include "src/common.sch") 35 | -------------------------------------------------------------------------------- /etc/R7RS/src/sumfp.sch: -------------------------------------------------------------------------------- 1 | ;;; SUMFP -- Compute sum of integers from 0 to 10000 using floating point 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (run n) 8 | (let loop ((i n) (sum 0.)) 9 | (if (< i 0.) 10 | sum 11 | (loop (- i 1.) (+ i sum))))) 12 | 13 | (define (main) 14 | (let* ((count (read)) 15 | (input1 (read)) 16 | (output (read)) 17 | (s2 (number->string count)) 18 | (s1 (number->string input1)) 19 | (name "sumfp")) 20 | (run-r7rs-benchmark 21 | (string-append name ":" s1 ":" s2) 22 | count 23 | (lambda () (run (hide count input1))) 24 | (lambda (result) (equal? result output))))) 25 | 26 | (include "src/common.sch") 27 | -------------------------------------------------------------------------------- /etc/R7RS/src/tail.sch: -------------------------------------------------------------------------------- 1 | ;;; TAIL -- One of the Kernighan and Van Wyk benchmarks. 2 | ;;; 3 | ;;; Modified for R6RS by Will Clinger. 4 | ;;; 5 | ;;; The key idea of this benchmark is that, for each iteration, 6 | ;;; the entire input is read line by line before any output 7 | ;;; is produced, and the lines are then written to the output 8 | ;;; in the reverse of the order in which they were read. 9 | 10 | (import (scheme base) 11 | (scheme read) 12 | (scheme write) 13 | (scheme file)) 14 | 15 | (define (tail-r-aux port file-so-far) 16 | (let ((x (read-line port))) 17 | (if (eof-object? x) 18 | file-so-far 19 | (tail-r-aux port (cons x file-so-far))))) 20 | 21 | (define (echo-lines-in-reverse-order in out) 22 | (for-each (lambda (line) (write-string line out) (newline out)) 23 | (tail-r-aux in '()))) 24 | 25 | (define (go input output) 26 | (call-with-input-file 27 | input 28 | (lambda (in) 29 | (if (file-exists? output) (delete-file output)) 30 | (call-with-output-file 31 | output 32 | (lambda (out) 33 | (echo-lines-in-reverse-order in out)))))) 34 | 35 | (define (main) 36 | (let* ((count (read)) 37 | (input1 (read)) 38 | (input2 (read)) 39 | (output (read)) 40 | (s3 (number->string count)) 41 | (s2 input2) 42 | (s1 input1) 43 | (name "tail")) 44 | (run-r7rs-benchmark 45 | (string-append name ":" s3) 46 | count 47 | (lambda () (go (hide count input1) (hide count input2))) 48 | (lambda (result) #t)))) 49 | 50 | (include "src/common.sch") 51 | -------------------------------------------------------------------------------- /etc/R7RS/src/tak.sch: -------------------------------------------------------------------------------- 1 | ;;; TAK -- A vanilla version of the TAKeuchi function. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (tak x y z) 8 | (if (not (< y x)) 9 | z 10 | (tak (tak (- x 1) y z) 11 | (tak (- y 1) z x) 12 | (tak (- z 1) x y)))) 13 | 14 | (define (main) 15 | (let* ((count (read)) 16 | (input1 (read)) 17 | (input2 (read)) 18 | (input3 (read)) 19 | (output (read)) 20 | (s4 (number->string count)) 21 | (s3 (number->string input3)) 22 | (s2 (number->string input2)) 23 | (s1 (number->string input1)) 24 | (name "tak")) 25 | (run-r7rs-benchmark 26 | (string-append name ":" s1 ":" s2 ":" s3 ":" s4) 27 | count 28 | (lambda () 29 | (tak (hide count input1) (hide count input2) (hide count input3))) 30 | (lambda (result) (equal? result output))))) 31 | 32 | (include "src/common.sch") 33 | -------------------------------------------------------------------------------- /etc/R7RS/src/takl.sch: -------------------------------------------------------------------------------- 1 | ;;; TAKL -- The TAKeuchi function using lists as counters. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define (listn n) 8 | (if (= n 0) 9 | '() 10 | (cons n (listn (- n 1))))) 11 | 12 | (define l18 (listn 18)) 13 | (define l12 (listn 12)) 14 | (define l6 (listn 6)) 15 | 16 | (define (mas x y z) 17 | (if (not (shorterp y x)) 18 | z 19 | (mas (mas (cdr x) y z) 20 | (mas (cdr y) z x) 21 | (mas (cdr z) x y)))) 22 | 23 | (define (shorterp x y) 24 | (and (not (null? y)) 25 | (or (null? x) 26 | (shorterp (cdr x) 27 | (cdr y))))) 28 | 29 | (define (main) 30 | (let* ((count (read)) 31 | (input1 (read)) 32 | (input2 (read)) 33 | (input3 (read)) 34 | (output (read)) 35 | (s4 (number->string count)) 36 | (s3 (number->string (length input3))) 37 | (s2 (number->string (length input2))) 38 | (s1 (number->string (length input1))) 39 | (name "takl")) 40 | (run-r7rs-benchmark 41 | (string-append name ":" s1 ":" s2 ":" s3 ":" s4) 42 | count 43 | (lambda () 44 | (mas (hide count input1) (hide count input2) (hide count input3))) 45 | (lambda (result) (equal? (length result) output))))) 46 | 47 | (include "src/common.sch") 48 | -------------------------------------------------------------------------------- /etc/R7RS/src/triangl.sch: -------------------------------------------------------------------------------- 1 | ;;; TRIANGL -- Board game benchmark. 2 | 3 | (import (scheme base) 4 | (scheme read) 5 | (scheme write)) 6 | 7 | (define *board* 8 | (list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1))) 9 | 10 | (define *sequence* 11 | (list->vector '(0 0 0 0 0 0 0 0 0 0 0 0 0 0))) 12 | 13 | (define *a* 14 | (list->vector '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 15 | 13 7 8 4 4 7 11 8 12 13 6 10 16 | 15 9 14 13 13 14 15 9 10 17 | 6 6))) 18 | 19 | (define *b* 20 | (list->vector '(2 4 7 5 8 9 3 6 10 5 9 8 21 | 12 13 14 8 9 5 2 4 7 5 8 22 | 9 3 6 10 5 9 8 12 13 14 23 | 8 9 5 5))) 24 | 25 | (define *c* 26 | (list->vector '(4 7 11 8 12 13 6 10 15 9 14 13 27 | 13 14 15 9 10 6 1 2 4 3 5 6 1 28 | 3 6 2 5 4 11 12 13 7 8 4 4))) 29 | 30 | (define *answer* '()) 31 | 32 | (define (attempt i depth) 33 | (cond ((= depth 14) 34 | (set! *answer* 35 | (cons (cdr (vector->list *sequence*)) *answer*)) 36 | #t) 37 | ((and (= 1 (vector-ref *board* (vector-ref *a* i))) 38 | (= 1 (vector-ref *board* (vector-ref *b* i))) 39 | (= 0 (vector-ref *board* (vector-ref *c* i)))) 40 | (vector-set! *board* (vector-ref *a* i) 0) 41 | (vector-set! *board* (vector-ref *b* i) 0) 42 | (vector-set! *board* (vector-ref *c* i) 1) 43 | (vector-set! *sequence* depth i) 44 | (do ((j 0 (+ j 1)) 45 | (depth (+ depth 1))) 46 | ((or (= j 36) (attempt j depth)) #f)) 47 | (vector-set! *board* (vector-ref *a* i) 1) 48 | (vector-set! *board* (vector-ref *b* i) 1) 49 | (vector-set! *board* (vector-ref *c* i) 0) #f) 50 | (else #f))) 51 | 52 | (define (test i depth) 53 | (set! *answer* '()) 54 | (attempt i depth) 55 | (car *answer*)) 56 | 57 | (define (main) 58 | (let* ((count (read)) 59 | (input1 (read)) 60 | (input2 (read)) 61 | (output (read)) 62 | (s3 (number->string count)) 63 | (s2 (number->string input2)) 64 | (s1 (number->string input1)) 65 | (name "triangl")) 66 | (run-r7rs-benchmark 67 | (string-append name ":" s1 ":" s2 ":" s3) 68 | count 69 | (lambda () (test (hide count input1) (hide count input2))) 70 | (lambda (result) (equal? result output))))) 71 | 72 | (include "src/common.sch") 73 | -------------------------------------------------------------------------------- /etc/R7RS/src/vecsort.sch: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ; 3 | ; Copyright 2007 William D Clinger. 4 | ; 5 | ; Permission to copy this software, in whole or in part, to use this 6 | ; software for any lawful purpose, and to redistribute this software 7 | ; is granted subject to the restriction that all copies made of this 8 | ; software must include this copyright notice in full. 9 | ; 10 | ; I also request that you send me a copy of any improvements that you 11 | ; make to this software so that they may be incorporated within it to 12 | ; the benefit of the Scheme community. 13 | ; 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | ; 16 | ; Vector sorting benchmark. 17 | ; 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | 20 | (import (rnrs base) 21 | (rnrs sorting) 22 | (rnrs control) 23 | (rnrs io simple) 24 | (rnrs arithmetic fixnums)) 25 | 26 | ; Returns a vector of all Unicode characters from lo to hi, 27 | ; inclusive. 28 | 29 | (define (all-characters lo hi) 30 | (define (loop sv0 sv1 chars) 31 | (cond ((fxchar sv1) chars))) 36 | (else 37 | (loop sv0 #xd7ff chars)))) 38 | (list->vector (loop (char->integer lo) (char->integer hi) '()))) 39 | 40 | (define (hashinteger c))) 43 | (fx- sv (fxxor sv (fxarithmetic-shift-right sv 2))))) 44 | (fxstring count)) 56 | (s2 (number->string input2)) 57 | (s1 (number->string input1)) 58 | (name "vecsort") 59 | (chars 60 | (hide count 61 | (all-characters 62 | (integer->char input1) (integer->char input2))))) 63 | (run-r6rs-benchmark 64 | (string-append name ":" s1 ":" s2 ":" s3) 65 | count 66 | (lambda () (hash-then-sort chars)) 67 | (lambda (result) (equal? result chars))))) 68 | -------------------------------------------------------------------------------- /etc/R7RS/src/wc.sch: -------------------------------------------------------------------------------- 1 | ;;; WC -- One of the Kernighan and Van Wyk benchmarks. 2 | ;;; Rewritten by Will Clinger into more idiomatic (and correct!) Scheme. 3 | 4 | (import (scheme base) 5 | (scheme read) 6 | (scheme write) 7 | (scheme file) 8 | (scheme char)) 9 | 10 | (define (wcport port) 11 | (define (loop nl nw nc inword?) 12 | (let ((x (read-char port))) 13 | (cond ((eof-object? x) 14 | (list nl nw nc)) 15 | ((char=? x #\space) 16 | (loop nl nw (+ nc 1) #f)) 17 | ((char=? x #\newline) 18 | (loop (+ nl 1) nw (+ nc 1) #f)) 19 | (else 20 | (loop nl (if inword? nw (+ nw 1)) (+ nc 1) #t))))) 21 | (loop 0 0 0 #f)) 22 | 23 | (define (go x) 24 | (call-with-input-file x wcport)) 25 | 26 | (define (main) 27 | (let* ((count (read)) 28 | (input (read)) 29 | (output (read)) 30 | (s2 (number->string count)) 31 | (s1 input) 32 | (name "wc")) 33 | (run-r7rs-benchmark 34 | (string-append name ":" s1 ":" s2) 35 | count 36 | (lambda () (go (hide count input))) 37 | (lambda (result) (equal? result output))))) 38 | 39 | (include "src/common.sch") 40 | -------------------------------------------------------------------------------- /etc/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | : ${GCC:=gcc} 4 | project_root=$(cd $(dirname $0); cd ../; pwd) 5 | 6 | for f in ${project_root}/src/*.c ${project_root}/extlib/benz/*.c $(find ${project_root}/contrib/* -name '*.c');do 7 | ${GCC} -c -O2 -pg -std=c99 -I${project_root}/extlib/benz/include $f -o `basename $f`.o & 8 | done 9 | wait 10 | ${GCC} main.c.o $(find . -maxdepth 1 -name '*.o' | grep -v main.c.o | grep -v load_piclib.c.o | grep -v init_contrib.c.o) load_piclib.c.o init_contrib.c.o \ 11 | -O2 -I${project_root}/extlib/benz/include -std=c99 -pg -lm -lreadline -o picrin 12 | rm *.o 13 | -------------------------------------------------------------------------------- /etc/libc_polyfill.c: -------------------------------------------------------------------------------- 1 | void abort() 2 | { 3 | while (1); 4 | } 5 | 6 | typedef char jmp_buf[1]; 7 | 8 | int setjmp(jmp_buf buf) 9 | { 10 | (void)buf; 11 | return 0; 12 | } 13 | 14 | void longjmp(jmp_buf buf, int r) 15 | { 16 | (void)buf; 17 | (void)r; 18 | while (1); 19 | } 20 | 21 | -------------------------------------------------------------------------------- /etc/picrin-c-keyword-highlight.el: -------------------------------------------------------------------------------- 1 | ;;; ADD ME TO YOUR .emacs.d/init.el 2 | 3 | (defun font-lock-user-keywords (mode &optional keywords) 4 | "Add user highlighting on KEYWORDS to given MODE. 5 | See `font-lock-add-keywords' and `font-lock-defaults'." 6 | (unless mode 7 | (error "mode should be non-nil ")) 8 | (font-lock-remove-keywords mode (get mode 'font-lock-user-keywords)) 9 | (font-lock-add-keywords mode keywords) 10 | (put mode 'font-lock-user-keywords keywords)) 11 | 12 | (font-lock-user-keywords 13 | 'c-mode 14 | '(("pic_try" . font-lock-keyword-face) 15 | ("pic_catch" . font-lock-keyword-face) 16 | ("pic_for_each" . font-lock-keyword-face))) 17 | -------------------------------------------------------------------------------- /etc/picrin-logo-fin01-01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picrin-scheme/picrin/7b725f45eec13f90911007034e59fae33c527d89/etc/picrin-logo-fin01-01.png -------------------------------------------------------------------------------- /etc/picrin-logo-fin01-02.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picrin-scheme/picrin/7b725f45eec13f90911007034e59fae33c527d89/etc/picrin-logo-fin01-02.png -------------------------------------------------------------------------------- /etc/picrin-scheme-keyword-highlight.el: -------------------------------------------------------------------------------- 1 | ;;; ADD ME TO YOUR .emacs.d/init.el 2 | 3 | (defun scheme-add-keywords (face-name keyword-rules) 4 | (let* ((keyword-list (mapcar #'(lambda (x) 5 | (symbol-name (cdr x))) 6 | keyword-rules)) 7 | (keyword-regexp (concat "(\\(" 8 | (regexp-opt keyword-list) 9 | "\\)[ \n]"))) 10 | (font-lock-add-keywords 'scheme-mode 11 | `((,keyword-regexp 1 ',face-name)))) 12 | (mapc #'(lambda (x) 13 | (put (cdr x) 14 | 'scheme-indent-function 15 | (car x))) 16 | keyword-rules)) 17 | 18 | (scheme-add-keywords 19 | 'font-lock-keyword-face 20 | '((1 . when) 21 | (1 . unless) 22 | (1 . define-library) 23 | (0 . import) 24 | (0 . export) 25 | (1 . letrec*) 26 | (1 . define-values) 27 | (1 . define-record-type) 28 | (1 . parameterize) 29 | (0 . values))) 30 | -------------------------------------------------------------------------------- /etc/tak.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme time) 3 | (scheme write)) 4 | 5 | (define (time f) 6 | (let ((start (current-jiffy))) 7 | (f) 8 | (inexact 9 | (/ (- (current-jiffy) start) 10 | (jiffies-per-second))))) 11 | 12 | (define (tak x y z) 13 | (if (> x y) 14 | (tak (tak (- x 1) y z) 15 | (tak (- y 1) z x) 16 | (tak (- z 1) x y)) 17 | y)) 18 | 19 | (define (f) 20 | (tak 12 6 0)) 21 | 22 | (write-simple (time f)) 23 | (newline) 24 | 25 | ; 70fb34 -> 10.374959 26 | ; fb6679 -> 4.275342 27 | -------------------------------------------------------------------------------- /lib/char.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | 8 | static pic_value 9 | pic_char_char_p(pic_state *pic) 10 | { 11 | pic_value v; 12 | 13 | pic_get_args(pic, "o", &v); 14 | 15 | return pic_bool_value(pic, pic_char_p(pic, v)); 16 | } 17 | 18 | static pic_value 19 | pic_char_char_to_integer(pic_state *pic) 20 | { 21 | char c; 22 | 23 | pic_get_args(pic, "c", &c); 24 | assert((c & 0x80) == 0); 25 | 26 | return pic_int_value(pic, c); 27 | } 28 | 29 | static pic_value 30 | pic_char_integer_to_char(pic_state *pic) 31 | { 32 | int i; 33 | 34 | pic_get_args(pic, "i", &i); 35 | 36 | if (i < 0 || i > 127) { 37 | pic_error(pic, "integer->char: integer out of char range", 1, pic_int_value(pic, i)); 38 | } 39 | 40 | return pic_char_value(pic, (char)i); 41 | } 42 | 43 | #define DEFINE_CHAR_CMP(op, name) \ 44 | static pic_value \ 45 | pic_char_##name##_p(pic_state *pic) \ 46 | { \ 47 | int argc, i; \ 48 | pic_value *argv; \ 49 | char c, d; \ 50 | \ 51 | pic_get_args(pic, "cc*", &c, &d, &argc, &argv); \ 52 | \ 53 | if (! (c op d)) \ 54 | return pic_false_value(pic); \ 55 | \ 56 | for (i = 0; i < argc; ++i) { \ 57 | c = d; \ 58 | TYPE_CHECK(pic, argv[i], char); \ 59 | d = pic_char(pic, argv[i]); \ 60 | \ 61 | if (! (c op d)) \ 62 | return pic_false_value(pic); \ 63 | } \ 64 | \ 65 | return pic_true_value(pic); \ 66 | } 67 | 68 | DEFINE_CHAR_CMP(==, eq) 69 | DEFINE_CHAR_CMP(<, lt) 70 | DEFINE_CHAR_CMP(>, gt) 71 | DEFINE_CHAR_CMP(<=, le) 72 | DEFINE_CHAR_CMP(>=, ge) 73 | 74 | void 75 | pic_init_char(pic_state *pic) 76 | { 77 | pic_defun(pic, "char?", pic_char_char_p); 78 | pic_defun(pic, "char->integer", pic_char_char_to_integer); 79 | pic_defun(pic, "integer->char", pic_char_integer_to_char); 80 | pic_defun(pic, "char=?", pic_char_eq_p); 81 | pic_defun(pic, "char?", pic_char_gt_p); 83 | pic_defun(pic, "char<=?", pic_char_le_p); 84 | pic_defun(pic, "char>=?", pic_char_ge_p); 85 | } 86 | -------------------------------------------------------------------------------- /lib/data.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | 8 | bool 9 | pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type) 10 | { 11 | if (pic_type(pic, obj) != PIC_TYPE_DATA) { 12 | return false; 13 | } 14 | return type == NULL || pic_data_ptr(pic, obj)->type == type; 15 | } 16 | 17 | void * 18 | pic_data(pic_state *PIC_UNUSED(pic), pic_value data) 19 | { 20 | return pic_data_ptr(pic, data)->data; 21 | } 22 | 23 | pic_value 24 | pic_data_value(pic_state *pic, void *userdata, const pic_data_type *type) 25 | { 26 | struct data *data; 27 | 28 | data = (struct data *)pic_obj_alloc(pic, sizeof(struct data), PIC_TYPE_DATA); 29 | data->type = type; 30 | data->data = userdata; 31 | 32 | return obj_value(pic, data); 33 | } 34 | -------------------------------------------------------------------------------- /lib/debug.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | #include "state.h" 8 | 9 | pic_value 10 | pic_get_backtrace(pic_state *pic) 11 | { 12 | size_t ai = pic_enter(pic); 13 | struct callinfo *ci; 14 | pic_value trace; 15 | 16 | trace = pic_lit_value(pic, ""); 17 | 18 | for (ci = pic->ci; ci != pic->cibase; --ci) { 19 | pic_value proc = ci->fp[0]; 20 | 21 | trace = pic_str_cat(pic, trace, pic_lit_value(pic, " at ")); 22 | trace = pic_str_cat(pic, trace, pic_lit_value(pic, "(anonymous lambda)")); 23 | 24 | if (pic_proc_func_p(pic, proc)) { 25 | trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (native function)\n")); 26 | } else { 27 | trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */ 28 | } 29 | } 30 | 31 | pic_leave(pic, ai); 32 | pic_protect(pic, trace); 33 | 34 | return trace; 35 | } 36 | 37 | #if PIC_USE_WRITE 38 | 39 | void 40 | pic_print_error(pic_state *pic, pic_value port, pic_value err) 41 | { 42 | if (! pic_error_p(pic, err)) { 43 | pic_fprintf(pic, port, "raise: ~s", err); 44 | } else { 45 | struct error *e; 46 | pic_value elem, it; 47 | 48 | e = pic_error_ptr(pic, err); 49 | if (! pic_eq_p(pic, obj_value(pic, e->type), pic_intern_lit(pic, ""))) { 50 | pic_fprintf(pic, port, "~s-", obj_value(pic, e->type)); 51 | } 52 | pic_fprintf(pic, port, "error: ~s", obj_value(pic, e->msg)); 53 | 54 | pic_for_each (elem, e->irrs, it) { /* print error irritants */ 55 | pic_fprintf(pic, port, " ~s", elem); 56 | } 57 | pic_fprintf(pic, port, "\n%s", pic_str(pic, obj_value(pic, e->stack), NULL)); 58 | } 59 | } 60 | 61 | #endif 62 | -------------------------------------------------------------------------------- /lib/ext/lib.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | #if PIC_USE_LIBRARY 9 | 10 | void 11 | pic_deflibrary(pic_state *pic, const char *lib) 12 | { 13 | pic_value name = pic_intern_cstr(pic, lib), v; 14 | 15 | v = pic_funcall(pic, "find-library", 1, name); 16 | if (! pic_bool(pic, v)) { 17 | pic_funcall(pic, "make-library", 1, name); 18 | } 19 | } 20 | 21 | void 22 | pic_in_library(pic_state *pic, const char *lib) 23 | { 24 | pic_value name = pic_intern_cstr(pic, lib); 25 | 26 | pic_funcall(pic, "current-library", 1, name); 27 | } 28 | 29 | void 30 | pic_export(pic_state *pic, int n, ...) 31 | { 32 | size_t ai = pic_enter(pic); 33 | va_list ap; 34 | 35 | va_start(ap, n); 36 | while (n--) { 37 | pic_value var = pic_intern_cstr(pic, va_arg(ap, const char *)); 38 | pic_funcall(pic, "library-export", 2, var, var); 39 | } 40 | va_end(ap); 41 | pic_leave(pic, ai); 42 | } 43 | 44 | #endif 45 | -------------------------------------------------------------------------------- /lib/ext/load.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | void 9 | pic_load(pic_state *pic, pic_value port) 10 | { 11 | pic_value form; 12 | size_t ai = pic_enter(pic); 13 | 14 | while (! pic_eof_p(pic, form = pic_read(pic, port))) { 15 | pic_funcall(pic, "eval", 1, form); 16 | pic_leave(pic, ai); 17 | } 18 | } 19 | 20 | void 21 | pic_load_cstr(pic_state *pic, const char *str) 22 | { 23 | pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r"); 24 | 25 | pic_try { 26 | pic_load(pic, port); 27 | } 28 | pic_catch(e) { 29 | pic_fclose(pic, port); 30 | pic_raise(pic, e); 31 | } 32 | pic_fclose(pic, port); 33 | } 34 | -------------------------------------------------------------------------------- /lib/include/picconf.h: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | /** enable libc */ 6 | /* #define PIC_USE_LIBC 1 */ 7 | 8 | /** enable stdio */ 9 | /* #define PIC_USE_STDIO 1 */ 10 | 11 | /** enable specific features */ 12 | /* #define PIC_USE_WRITE 1 */ 13 | /* #define PIC_USE_LIBRARY 1 */ 14 | 15 | /** essential external functions */ 16 | /* #define PIC_JMPBUF jmp_buf */ 17 | /* #define PIC_SETJMP(pic, buf) setjmp(buf) */ 18 | /* #define PIC_LONGJMP(pic, buf, val) longjmp((buf), (val)) */ 19 | /* #define PIC_ABORT(pic) abort() */ 20 | 21 | /** I/O configuration */ 22 | /* #define PIC_BUFSIZ 1024 */ 23 | -------------------------------------------------------------------------------- /lib/include/picrin/extra.h: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #ifndef PICRIN_EXTRA_H 6 | #define PICRIN_EXTRA_H 7 | 8 | #if defined(__cplusplus) 9 | extern "C" { 10 | #endif 11 | 12 | 13 | #if PIC_USE_LIBC 14 | void *pic_default_allocf(void *, void *, size_t); 15 | #endif 16 | 17 | pic_value pic_read(pic_state *, pic_value port); 18 | pic_value pic_read_cstr(pic_state *, const char *); 19 | 20 | void pic_load(pic_state *, pic_value port); 21 | void pic_load_cstr(pic_state *, const char *); 22 | 23 | #if PIC_USE_STDIO 24 | pic_value pic_fopen(pic_state *, FILE *, const char *mode); 25 | #endif 26 | 27 | 28 | /* 29 | * library 30 | */ 31 | 32 | #if PIC_USE_LIBRARY 33 | void pic_deflibrary(pic_state *, const char *lib); 34 | void pic_in_library(pic_state *, const char *lib); 35 | void pic_export(pic_state *, int n, ...); 36 | #endif 37 | 38 | 39 | /* for debug */ 40 | 41 | #if PIC_USE_WRITE 42 | void pic_print_error(pic_state *, pic_value port, pic_value err); 43 | #endif 44 | 45 | #if defined(__cplusplus) 46 | } 47 | #endif 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /lib/record.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | 8 | pic_value 9 | pic_make_record(pic_state *pic, pic_value type, pic_value datum) 10 | { 11 | struct record *rec; 12 | 13 | rec = (struct record *)pic_obj_alloc(pic, sizeof(struct record), PIC_TYPE_RECORD); 14 | rec->type = type; 15 | rec->datum = datum; 16 | 17 | return obj_value(pic, rec); 18 | } 19 | 20 | static pic_value 21 | pic_rec_make_record(pic_state *pic) 22 | { 23 | pic_value type, datum; 24 | 25 | pic_get_args(pic, "oo", &type, &datum); 26 | 27 | return pic_make_record(pic, type, datum); 28 | } 29 | 30 | static pic_value 31 | pic_rec_record_p(pic_state *pic) 32 | { 33 | pic_value rec; 34 | 35 | pic_get_args(pic, "o", &rec); 36 | 37 | return pic_bool_value(pic, pic_rec_p(pic, rec)); 38 | } 39 | 40 | static pic_value 41 | pic_rec_record_type(pic_state *pic) 42 | { 43 | pic_value rec; 44 | 45 | pic_get_args(pic, "r", &rec); 46 | 47 | return pic_rec_ptr(pic, rec)->type; 48 | } 49 | 50 | static pic_value 51 | pic_rec_record_datum(pic_state *pic) 52 | { 53 | pic_value rec; 54 | 55 | pic_get_args(pic, "r", &rec); 56 | 57 | return pic_rec_ptr(pic, rec)->datum; 58 | } 59 | 60 | void 61 | pic_init_record(pic_state *pic) 62 | { 63 | pic_defun(pic, "make-record", pic_rec_make_record); 64 | pic_defun(pic, "record?", pic_rec_record_p); 65 | pic_defun(pic, "record-type", pic_rec_record_type); 66 | pic_defun(pic, "record-datum", pic_rec_record_datum); 67 | } 68 | -------------------------------------------------------------------------------- /lib/state.h: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #ifndef PICRIN_STATE_H 6 | #define PICRIN_STATE_H 7 | 8 | #if defined(__cplusplus) 9 | extern "C" { 10 | #endif 11 | 12 | #include "khash.h" 13 | #include "vm.h" 14 | 15 | struct callinfo { 16 | int argc, retc; 17 | const struct code *ip; 18 | pic_value *fp; 19 | struct irep *irep; 20 | struct context *cxt; 21 | int regc; 22 | pic_value *regs; 23 | struct context *up; 24 | }; 25 | 26 | KHASH_DECLARE(oblist, struct string *, struct identifier *) 27 | 28 | struct pic_state { 29 | pic_allocf allocf; 30 | void *userdata; 31 | 32 | struct cont *cc; 33 | 34 | pic_value *sp; 35 | pic_value *stbase, *stend; 36 | 37 | struct callinfo *ci; 38 | struct callinfo *cibase, *ciend; 39 | 40 | const struct code *ip; 41 | 42 | pic_value dyn_env; 43 | 44 | pic_value features; 45 | 46 | khash_t(oblist) oblist; /* string to symbol */ 47 | int ucnt; 48 | pic_value globals; /* dict */ 49 | pic_value macros; /* weak */ 50 | 51 | bool gc_enable; 52 | struct heap *heap; 53 | struct object **arena; 54 | size_t arena_size, arena_idx; 55 | 56 | pic_value err; 57 | 58 | pic_panicf panicf; 59 | }; 60 | 61 | struct heap *pic_heap_open(pic_state *); 62 | void pic_heap_close(pic_state *, struct heap *); 63 | 64 | pic_value pic_global_ref(pic_state *pic, pic_value uid); 65 | void pic_global_set(pic_state *pic, pic_value uid, pic_value value); 66 | 67 | void pic_vm_tear_off(pic_state *pic); 68 | 69 | #if defined(__cplusplus) 70 | } 71 | #endif 72 | 73 | #endif 74 | -------------------------------------------------------------------------------- /lib/var.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | #include "state.h" 8 | 9 | /* implementated by deep binding */ 10 | 11 | static pic_value 12 | var_call(pic_state *pic) 13 | { 14 | pic_value self, val; 15 | int n; 16 | 17 | n = pic_get_args(pic, "&|o", &self, &val); 18 | 19 | if (n == 0) { 20 | pic_value env, it; 21 | 22 | pic_for_each(env, pic->dyn_env, it) { 23 | if (pic_weak_has(pic, env, self)) { 24 | return pic_weak_ref(pic, env, self); 25 | } 26 | } 27 | PIC_UNREACHABLE(); /* logic flaw */ 28 | } else { 29 | pic_value conv; 30 | 31 | conv = pic_closure_ref(pic, 0); 32 | if (! pic_false_p(pic, conv)) { 33 | val = pic_call(pic, conv, 1, val); 34 | } 35 | pic_weak_set(pic, pic_car(pic, pic->dyn_env), self, val); 36 | return pic_undef_value(pic); 37 | } 38 | } 39 | 40 | pic_value 41 | pic_make_var(pic_state *pic, pic_value init, pic_value conv) 42 | { 43 | pic_value var, env = pic->dyn_env; 44 | 45 | var = pic_lambda(pic, var_call, 1, conv); 46 | while (1) { 47 | if (pic_nil_p(pic, pic_cdr(pic, env))) { /* top dyn env */ 48 | if (! pic_false_p(pic, conv)) { 49 | init = pic_call(pic, conv, 1, init); 50 | } 51 | pic_weak_set(pic, pic_car(pic, env), var, init); 52 | break; 53 | } 54 | env = pic_cdr(pic, env); 55 | } 56 | return var; 57 | } 58 | 59 | static pic_value 60 | pic_var_make_parameter(pic_state *pic) 61 | { 62 | pic_value init, conv = pic_false_value(pic); 63 | 64 | pic_get_args(pic, "o|l", &init, &conv); 65 | 66 | return pic_make_var(pic, init, conv); 67 | } 68 | 69 | static pic_value 70 | pic_var_with_dynamic_environment(pic_state *pic) 71 | { 72 | pic_value alist, thunk, env, it, elt, val; 73 | 74 | pic_get_args(pic, "ol", &alist, &thunk); 75 | 76 | env = pic_make_weak(pic); 77 | pic_for_each(elt, alist, it) { 78 | pic_weak_set(pic, env, pic_car(pic, elt), pic_cdr(pic, elt)); 79 | } 80 | pic->dyn_env = pic_cons(pic, env, pic->dyn_env); 81 | val = pic_call(pic, thunk, 0); 82 | pic->dyn_env = pic_cdr(pic, pic->dyn_env); 83 | return val; 84 | } 85 | 86 | void 87 | pic_init_var(pic_state *pic) 88 | { 89 | pic_defun(pic, "make-parameter", pic_var_make_parameter); 90 | pic_defun(pic, "with-dynamic-environment", pic_var_with_dynamic_environment); 91 | } 92 | -------------------------------------------------------------------------------- /lib/vm.h: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #ifndef PICRIN_VM_H 6 | #define PICRIN_VM_H 7 | 8 | #if defined(__cplusplus) 9 | extern "C" { 10 | #endif 11 | 12 | enum { 13 | OP_NOP = 0, 14 | OP_POP = 1, 15 | OP_PUSHUNDEF = 2, 16 | OP_PUSHNIL = 3, 17 | OP_PUSHTRUE = 4, 18 | OP_PUSHFALSE = 5, 19 | OP_PUSHINT = 6, 20 | OP_PUSHFLOAT = 7, 21 | OP_PUSHCHAR = 8, 22 | OP_PUSHEOF = 9, 23 | OP_PUSHCONST = 10, 24 | OP_GREF = 11, 25 | OP_GSET = 12, 26 | OP_LREF = 13, 27 | OP_LSET = 14, 28 | OP_CREF = 15, 29 | OP_CSET = 16, 30 | OP_JMP = 17, 31 | OP_JMPIF = 18, 32 | OP_NOT = 19, 33 | OP_CALL = 20, 34 | OP_TAILCALL = 21, 35 | OP_RET = 22, 36 | OP_LAMBDA = 23, 37 | OP_CONS = 24, 38 | OP_CAR = 25, 39 | OP_CDR = 26, 40 | OP_NILP = 27, 41 | OP_SYMBOLP = 28, 42 | OP_PAIRP = 29, 43 | OP_ADD = 30, 44 | OP_SUB = 31, 45 | OP_MUL = 32, 46 | OP_DIV = 33, 47 | OP_EQ = 34, 48 | OP_LT = 35, 49 | OP_LE = 36, 50 | OP_GT = 37, 51 | OP_GE = 38, 52 | OP_STOP = 39 53 | }; 54 | 55 | #if defined(__cplusplus) 56 | } 57 | #endif 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /lib/weak.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "object.h" 7 | 8 | KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) 9 | 10 | pic_value 11 | pic_make_weak(pic_state *pic) 12 | { 13 | struct weak *weak; 14 | 15 | weak = (struct weak *)pic_obj_alloc(pic, sizeof(struct weak), PIC_TYPE_WEAK); 16 | weak->prev = NULL; 17 | kh_init(weak, &weak->hash); 18 | 19 | return obj_value(pic, weak); 20 | } 21 | 22 | pic_value 23 | pic_weak_ref(pic_state *pic, pic_value weak, pic_value key) 24 | { 25 | khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; 26 | int it; 27 | 28 | it = kh_get(weak, h, obj_ptr(pic, key)); 29 | if (it == kh_end(h)) { 30 | pic_error(pic, "element not found for given key", 1, key); 31 | } 32 | return kh_val(h, it); 33 | } 34 | 35 | void 36 | pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val) 37 | { 38 | khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; 39 | int ret; 40 | int it; 41 | 42 | it = kh_put(weak, h, obj_ptr(pic, key), &ret); 43 | kh_val(h, it) = val; 44 | } 45 | 46 | bool 47 | pic_weak_has(pic_state *pic, pic_value weak, pic_value key) 48 | { 49 | khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; 50 | 51 | return kh_get(weak, h, obj_ptr(pic, key)) != kh_end(h); 52 | } 53 | 54 | void 55 | pic_weak_del(pic_state *pic, pic_value weak, pic_value key) 56 | { 57 | khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; 58 | int it; 59 | 60 | it = kh_get(weak, h, obj_ptr(pic, key)); 61 | if (it == kh_end(h)) { 62 | pic_error(pic, "element not found for given key", 1, key); 63 | } 64 | kh_del(weak, h, it); 65 | } 66 | 67 | 68 | static pic_value 69 | weak_call(pic_state *pic) 70 | { 71 | pic_value key, val, weak; 72 | int n; 73 | 74 | n = pic_get_args(pic, "o|o", &key, &val); 75 | 76 | if (! obj_p(pic, key)) { 77 | pic_error(pic, "attempted to set a non-object key", 1, key); 78 | } 79 | 80 | weak = pic_closure_ref(pic, 0); 81 | 82 | if (n == 1) { 83 | if (! pic_weak_has(pic, weak, key)) { 84 | return pic_false_value(pic); 85 | } 86 | return pic_cons(pic, key, pic_weak_ref(pic, weak, key)); 87 | } else { 88 | if (pic_false_p(pic, val)) { 89 | if (pic_weak_has(pic, weak, key)) { 90 | pic_weak_del(pic, weak, key); 91 | } 92 | } else { 93 | pic_weak_set(pic, weak, key, val); 94 | } 95 | return pic_undef_value(pic); 96 | } 97 | } 98 | 99 | static pic_value 100 | pic_weak_make_ephemeron_table(pic_state *pic) 101 | { 102 | pic_get_args(pic, ""); 103 | 104 | return pic_lambda(pic, weak_call, 1, pic_make_weak(pic)); 105 | } 106 | 107 | void 108 | pic_init_weak(pic_state *pic) 109 | { 110 | pic_defun(pic, "make-ephemeron-table", pic_weak_make_ephemeron_table); 111 | } 112 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | void 9 | pic_init_picrin(pic_state *pic) 10 | { 11 | void pic_init_contrib(pic_state *); 12 | void pic_load_piclib(pic_state *); 13 | 14 | pic_init_contrib(pic); 15 | pic_load_piclib(pic); 16 | } 17 | 18 | int picrin_argc; 19 | char **picrin_argv; 20 | char **picrin_envp; 21 | 22 | int 23 | main(int argc, char *argv[], char **envp) 24 | { 25 | pic_state *pic; 26 | pic_value e; 27 | int status; 28 | 29 | pic = pic_open(pic_default_allocf, NULL); 30 | 31 | picrin_argc = argc; 32 | picrin_argv = argv; 33 | picrin_envp = envp; 34 | 35 | pic_try { 36 | pic_init_picrin(pic); 37 | 38 | pic_funcall(pic, "picrin.main:main", 0); 39 | 40 | status = 0; 41 | } 42 | pic_catch(e) { 43 | pic_print_error(pic, pic_stderr(pic), e); 44 | status = 1; 45 | } 46 | 47 | pic_close(pic); 48 | 49 | return status; 50 | } 51 | -------------------------------------------------------------------------------- /src/tiny-main.c: -------------------------------------------------------------------------------- 1 | /** 2 | * See Copyright Notice in picrin.h 3 | */ 4 | 5 | #include "picrin.h" 6 | #include "picrin/extra.h" 7 | 8 | int 9 | main() 10 | { 11 | pic_state *pic; 12 | pic_value e, form; 13 | int status; 14 | 15 | pic = pic_open(pic_default_allocf, NULL); 16 | 17 | pic_try { 18 | while (1) { 19 | size_t ai = pic_enter(pic); 20 | pic_printf(pic, "> "); 21 | form = pic_read(pic, pic_stdin(pic)); 22 | if (pic_eof_p(pic, form)) { 23 | break; 24 | } 25 | pic_printf(pic, "~s\n", pic_funcall(pic, "eval", 1, form)); 26 | pic_leave(pic, ai); 27 | } 28 | 29 | status = 0; 30 | } 31 | pic_catch(e) { 32 | pic_print_error(pic, pic_stderr(pic), e); 33 | status = 1; 34 | } 35 | 36 | pic_close(pic); 37 | 38 | return status; 39 | } 40 | -------------------------------------------------------------------------------- /t/byteio.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write) 3 | (scheme file)) 4 | 5 | 6 | (let ((string-port (open-input-string "hello"))) 7 | (display "read-string: ") 8 | (write (read-string 4 string-port)) 9 | (newline) 10 | (display "read-string more: ") 11 | (write (read-string 4 string-port)) 12 | (newline)) 13 | 14 | (let ((byte-port (open-input-bytevector (bytevector 1 2 3 4 5 6 7 8))) 15 | (buf (make-bytevector 4 98))) 16 | (display "read-u8: ") 17 | (write (read-u8 byte-port)) 18 | (newline) 19 | (display "peek-u8: ") 20 | (write (peek-u8 byte-port)) 21 | (newline) 22 | (display "read-bytevector: ") 23 | (write (read-bytevector 4 byte-port)) 24 | (newline) 25 | (display "read-bytevector!: read size: ") 26 | (write (read-bytevector! buf byte-port 1 3)) 27 | (display ": read content: ") 28 | (write buf) 29 | (newline) 30 | (display "read-bytevector!: read size: ") 31 | (write (read-bytevector! buf byte-port)) 32 | (display ": read content: ") 33 | (write buf) 34 | (newline)) 35 | -------------------------------------------------------------------------------- /t/closure.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write)) 3 | 4 | (begin 5 | 6 | (define foo (lambda (a) 7 | (lambda () 8 | a))) 9 | (define bar (foo 1)) 10 | 11 | ; must be 1 12 | (write (bar)) 13 | (newline) 14 | 15 | (define baz (foo 2)) 16 | 17 | ; must be 2 18 | (write (baz)) 19 | (newline) 20 | 21 | ; must be 1 22 | (write (bar)) 23 | (newline)) 24 | -------------------------------------------------------------------------------- /t/dynamic-wind.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write)) 3 | 4 | (define (print obj) 5 | (write obj) 6 | (newline) 7 | obj) 8 | 9 | (print 10 | (dynamic-wind 11 | (lambda () (print 'before1)) 12 | (lambda () 13 | (define cont #f) 14 | (print 1) 15 | (dynamic-wind 16 | (lambda () (print 'before2)) 17 | (lambda () 18 | (print 2) 19 | (set! cont (call/cc values))) 20 | (lambda () (print 'after2))) 21 | (dynamic-wind 22 | (lambda () (print 'before3)) 23 | (lambda () 24 | (print 3) 25 | (if (procedure? cont) 26 | (cont 42) 27 | cont)) 28 | (lambda () (print 'after3)))) 29 | (lambda () (print 'after1)))) 30 | 31 | ; before1 32 | ; 1 33 | ; before2 34 | ; 2 35 | ; after2 36 | ; before3 37 | ; 3 38 | ; after3 39 | ; before2 40 | ; after2 41 | ; before3 42 | ; 3 43 | ; after3 44 | ; after1 45 | ; => 42 46 | 47 | (print 48 | (let ((path '()) 49 | (c #f)) 50 | (let ((add (lambda (s) 51 | (set! path (cons s path))))) 52 | (dynamic-wind 53 | (lambda () (add 'connect)) 54 | (lambda () 55 | (add (call-with-current-continuation 56 | (lambda (c0) 57 | (set! c c0) 58 | 'talk1)))) 59 | (lambda () (add 'disconnect))) 60 | (if (< (length path) 4) 61 | (c 'talk2) 62 | (reverse path))))) 63 | 64 | ; (connect talk1 disconnect connect talk2 disconnect) 65 | -------------------------------------------------------------------------------- /t/escape.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin control) 3 | (picrin test)) 4 | 5 | (test-begin) 6 | 7 | (test 1 (escape (lambda (exit) (begin (exit 1) 2)))) 8 | 9 | (define cont #f) 10 | 11 | (test "calling dead escape continuation" 12 | (guard (c ((error-object? c) (error-object-message c))) 13 | (escape (lambda (exit) (set! cont exit))) 14 | (cont 3))) 15 | 16 | (test-end) 17 | -------------------------------------------------------------------------------- /t/exception.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write)) 3 | 4 | (define (print obj) 5 | (write obj) 6 | (newline) 7 | obj) 8 | 9 | (print 10 | (call/cc 11 | (lambda (k) 12 | (with-exception-handler 13 | (lambda (x) 14 | (write "condition: ") 15 | (write x) 16 | (newline) 17 | (k 'exception)) 18 | (lambda () 19 | (+ 1 (raise 'an-error))))))) 20 | 21 | (print 22 | (with-exception-handler 23 | (lambda (con) 24 | (cond 25 | ((string? con) 26 | (print con)) 27 | (else 28 | (print "a warning has been issued"))) 29 | 42) 30 | (lambda () 31 | (+ (raise-continuable "should be a number") 32 | 23)))) 33 | -------------------------------------------------------------------------------- /t/hello.scm: -------------------------------------------------------------------------------- 1 | (import (scheme write)) 2 | 3 | (write-simple "hello world") 4 | -------------------------------------------------------------------------------- /t/issue/234.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (define-syntax fard 7 | (syntax-rules () 8 | ((fard a b) (- a b)))) 9 | 10 | (test -1 (fard 1 2)) 11 | 12 | (define (fard a b) 13 | (+ a b)) 14 | 15 | (test 3 (fard 1 2)) 16 | 17 | (test 3 (apply fard (list 1 2))) 18 | 19 | (test-end) 20 | -------------------------------------------------------------------------------- /t/issue/250.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme file)) 3 | 4 | (with-output-to-file "test.txt" 5 | (write "TEST")) 6 | -------------------------------------------------------------------------------- /t/issue/257.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (map +) 5 | -------------------------------------------------------------------------------- /t/issue/282.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (test "-0.1" (substring (number->string -0.1) 0 4)) 7 | (test "-0.9" (substring (number->string -0.9) 0 4)) 8 | (test "-1.0" (substring (number->string -1.0) 0 4)) 9 | (test "-1.1" (substring (number->string -1.1) 0 4)) 10 | 11 | (test-end) 12 | -------------------------------------------------------------------------------- /t/issue/308.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | $PICRIN <<'EOF' 4 | (import (srfi 1)) 5 | (import (picrin repl)) 6 | (every = '(1 2 3) '(1 2 3)) 7 | 8 | EOF 9 | -------------------------------------------------------------------------------- /t/issue/312.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | (test #f (equal? (make-list 10 1) (make-list 11 1))) 6 | 7 | (let ((l1 (list 1 1)) 8 | (l2 (list 1 1)) 9 | (l3 (list 1 1 1))) 10 | (set-cdr! l1 l1) 11 | (set-cdr! l2 l2) 12 | (set-cdr! (cdr l3) l3) 13 | 14 | (test #f (equal? l1 (make-list 10 1))) 15 | (test #t (equal? l1 l1)) 16 | (test #t (equal? l1 l2)) 17 | (test #t (equal? l1 l3))) 18 | 19 | (test-end) 20 | -------------------------------------------------------------------------------- /t/issue/322.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (test #f (string->number "12e43r")) 7 | 8 | (test #f (string->number "12e+43r")) 9 | 10 | (test #f (string->number "12e+43e54")) 11 | 12 | (test #f (string->number "12e+")) 13 | 14 | (test #f (string->number "12e")) 15 | 16 | (test #f (string->number "+12e")) 17 | 18 | (test #f (string->number "-12e")) 19 | 20 | (test -12 (string->number "-12")) 21 | 22 | (test -12.0 (string->number "-12.0")) 23 | 24 | (test #f (string->number "-12.0e-5t")) 25 | 26 | (test-end) 27 | -------------------------------------------------------------------------------- /t/issue/foo-map.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (define (char-inc c) 7 | (integer->char (+ (char->integer c) 1))) 8 | 9 | (define (char-dec c) 10 | (integer->char (- (char->integer c) 1))) 11 | 12 | (test "tsvcmxdmqr" 13 | (string-map (lambda (c k) 14 | ((if (eqv? k #\+) char-inc char-dec) c)) 15 | "studlycnps xxx" 16 | "+-+-+-+-+-")) 17 | 18 | (test "abcdefgh" 19 | (begin 20 | (define s "") 21 | (string-for-each 22 | (lambda (a b) 23 | (set! s (string-append s (string a b)))) 24 | "aceg hij" 25 | "bdfh") 26 | s)) 27 | 28 | (test #(#(1 6 9) #(2 7 10) #(3 8 11)) 29 | (vector-map vector #(1 2 3 4 5) #(6 7 8) #(9 10 11 12))) 30 | 31 | (test "(1 4 1)(2 5 1)" 32 | (call-with-port (open-output-string) 33 | (lambda (port) 34 | (parameterize ((current-output-port port)) 35 | (vector-for-each 36 | (lambda args (display args)) 37 | #(1 2 3) 38 | #(4 5) 39 | #(1 1)) 40 | (get-output-string port))))) 41 | 42 | (test-end) 43 | -------------------------------------------------------------------------------- /t/issue/parameterize.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (define a #f) 7 | 8 | (parameterize () 9 | (set! a (make-parameter 1))) 10 | 11 | (test 1 (a)) 12 | 13 | (test-end) 14 | -------------------------------------------------------------------------------- /t/issue/pic_call.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme read) 3 | (scheme file) 4 | (scheme lazy) 5 | (scheme write) 6 | (srfi 1) 7 | (picrin base) 8 | (picrin test)) 9 | 10 | (test-begin) 11 | 12 | (define trace '()) 13 | 14 | (define task-queue (make-parameter '() (lambda (x) (set! trace (cons x trace)) x))) 15 | 16 | (define expand 17 | (lambda () 18 | (task-queue))) 19 | 20 | (define result (expand)) 21 | (test '() result) 22 | (test '(()) trace) 23 | 24 | (test-end) 25 | -------------------------------------------------------------------------------- /t/issue/string-copy.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (test "456" (string-copy (string-copy "1234567" 3) 0 3)) 7 | 8 | (test-end) 9 | -------------------------------------------------------------------------------- /t/letrec.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write)) 3 | 4 | (define (print obj) 5 | (write obj) 6 | (newline) 7 | obj) 8 | 9 | (letrec ((my-odd? (lambda (n) 10 | (if (= n 0) 11 | #t 12 | (not (my-even? (- n 1)))))) 13 | (my-even? (lambda (n) 14 | (if (= n 0) 15 | #t 16 | (not (my-odd? (- n 1))))))) 17 | (print '(my-odd? 42)) 18 | (print (my-odd? 42)) 19 | (print '(my-even? 57)) 20 | (print (my-even? 57))) 21 | 22 | (print 70) 23 | (print 24 | (let ((x 2) 25 | (y 3)) 26 | (let* ((x 7) 27 | (z (+ x y))) 28 | (* z x)))) 29 | 30 | (print 5) 31 | (print 32 | (letrec ((p 33 | (lambda (x) 34 | (+ 1 (q (- x 1))))) 35 | (q 36 | (lambda (y) 37 | (if (zero? y) 38 | 0 39 | (+ 1 (p (- y 1)))))) 40 | (x (p 5)) 41 | (y x)) 42 | y)) 43 | 44 | ;; (let () 45 | ;; (define my-odd? (lambda (n) 46 | ;; (if (= n 0) 47 | ;; #t 48 | ;; (not (my-even? (- n 1)))))) 49 | ;; (define my-even? (lambda (n) 50 | ;; (if (= n 0) 51 | ;; #t 52 | ;; (not (my-odd? (- n 1)))))) 53 | ;; (print (my-odd? 42)) 54 | ;; (print (my-even? 57))) 55 | -------------------------------------------------------------------------------- /t/override.scm: -------------------------------------------------------------------------------- 1 | (import (picrin base) 2 | (picrin test)) 3 | 4 | (test-begin) 5 | 6 | (define orig-cons cons) 7 | 8 | (set! symbol? list) 9 | 10 | (test '(1) 11 | (symbol? 1)) 12 | 13 | (test-end) 14 | -------------------------------------------------------------------------------- /t/parameterize.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write) 3 | (picrin test)) 4 | 5 | (test-begin) 6 | 7 | (test "piece by piece by piece.\n" 8 | (parameterize 9 | ((current-output-port (open-output-string))) 10 | (display "piece") 11 | (display " by piece ") 12 | (display "by piece.") 13 | (newline) 14 | (get-output-string))) 15 | 16 | (test-end) 17 | -------------------------------------------------------------------------------- /t/renaming-import.scm: -------------------------------------------------------------------------------- 1 | (define-library (foo) 2 | (import (except (rename (prefix (only (scheme base) car cdr cons) my-) 3 | (my-car my-kar) 4 | (my-cdr my-kdr)) 5 | my-kar)) 6 | 7 | ;; (import (rename (scheme base) 8 | ;; (car my-kar) 9 | ;; (cdr my-cdr))) 10 | 11 | (export my-kdr my-cons)) 12 | -------------------------------------------------------------------------------- /t/shebang.scm: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | #| -*- scheme -*- 3 | exec picrin $0 "$@" 4 | |# 5 | 6 | (import (scheme base) 7 | (scheme write)) 8 | 9 | (write (list 1 2 3)) 10 | -------------------------------------------------------------------------------- /t/tail-call.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base)) 2 | 3 | ;;; always returns zero 4 | (define (zero n) 5 | (if (zero? n) 6 | 0 7 | (zero (- n 1)))) 8 | 9 | ;;; using apply 10 | (define (zero-2 n) 11 | (if (zero? n) 12 | 0 13 | (apply zero-2 (list (- n 1))))) 14 | 15 | (zero-2 100000) 16 | -------------------------------------------------------------------------------- /t/tailcall.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme write)) 3 | 4 | (define (sum k acc) 5 | (if (zero? k) 6 | acc 7 | (sum (- k 1) (+ k acc)))) 8 | 9 | (write (sum 1000 0)) 10 | (newline) 11 | -------------------------------------------------------------------------------- /tools/mkboot.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | 5 | sub constant($$) { 6 | # The maximum length of a string literal is 509 characters in C89. 7 | # That is why src is split into short strings. 8 | my ($var, $src) = @_; 9 | print "static const char ${var}[][80] = {\n"; 10 | my @lines = $src =~ /.{0,80}/gs; 11 | foreach (@lines) { 12 | s/\\/\\\\/g; 13 | s/"/\\"/g; 14 | s/\n/\\n/g; 15 | print "\"$_\",\n"; 16 | } 17 | print "};\n\n"; 18 | } 19 | 20 | local $/ = undef; 21 | 22 | print <); 29 | close(IN); 30 | print <); 36 | close(IN); 37 | print <; 40 | close IN; 41 | 42 | constant($var, $src); 43 | } 44 | 45 | print <