├── .gitignore ├── AUTHORS ├── COPYING.BSD ├── COPYING.GPL-3 ├── COPYING.LGPL-3 ├── ChangeLog ├── NEWS ├── NOTES ├── README ├── README.trc-testing ├── docs ├── index.org └── spells.scm ├── examples └── zcat.sps ├── pkg-list.scm ├── spells ├── algebraic-types.sls ├── algebraic-types │ └── helpers.sls ├── alist.sls ├── args-fold.sls ├── array-search.sls ├── ascii.sls ├── assert.sls ├── awk.sls ├── awk │ ├── helpers.sls │ └── range-tests.sls ├── cells.sls ├── condition.sls ├── define-values.sls ├── delimited-control.sls ├── delimited-readers.sls ├── engines.sls ├── engines │ └── timer.sls ├── error.sls ├── field-readers.sls ├── filesys.sls ├── filesys │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mosh.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── finite-types.sls ├── foreign.sls ├── foreign │ ├── compat.ikarus.sls │ ├── compat.mzscheme.sls │ ├── compat.ypsilon.sls │ ├── config.sls.in │ ├── conjure.sls │ ├── frozen-bytes.sls │ └── util.sls ├── format.sls ├── gc.sls ├── gc │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.mosh.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── gzip.sls ├── hash-utils.sls ├── include.sls ├── include │ ├── compat.ikarus.sls │ ├── compat.sls │ └── helpers.sls ├── list-utils.sls ├── logging.sls ├── match.sls ├── misc.sls ├── misc │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mosh.sls │ ├── compat.mzscheme.sls │ ├── compat.sls │ └── compat.ypsilon.sls ├── network.sls ├── network │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.mosh.sls │ ├── compat.mzscheme.sls │ ├── compat.ypsilon.sls │ └── utils.sls ├── operations.sls ├── opt-args.sls ├── pathname.sls ├── pathname │ ├── os-string.mzscheme.sls │ └── os-string.sls ├── ports.sls ├── pretty-print.ikarus.sls ├── pretty-print.sls ├── private │ ├── ascii.scm │ ├── assert.scm │ ├── condition.scm │ ├── format.scm │ ├── gc.scm │ ├── misc.scm │ ├── skip-char-set.scm │ ├── stexidoc.sls │ └── xvector.scm ├── procedure-annotations.sls ├── process.sls ├── process │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.mosh.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── queue.sls ├── record-types.sls ├── record-types │ └── expand-drt.sls ├── string-utils.sls ├── syntax-utils.sls ├── sysutils.sls ├── sysutils │ ├── compat.guile.sls │ ├── compat.ikarus.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── table.sls ├── table │ └── compat.sls ├── test-runner.sls ├── test-runner │ └── env.sls ├── testing-utils.sls ├── time-it.ikarus.sls ├── time-lib.sls ├── tracing.sls ├── tracing │ ├── compat.ikarus.sls │ └── compat.sls ├── xvector.sls └── zipper-tree.sls └── tests ├── algebraic-types.scm ├── args-fold.scm ├── awk.scm ├── define-values.scm ├── delimited-control.scm ├── delimited-readers.scm ├── filesys.scm ├── finite-types.scm ├── fmt.scm ├── foof-loop.scm ├── foreign.scm ├── format.scm ├── list-utils.scm ├── logging.scm ├── match.scm ├── misc.scm ├── operations.scm ├── opt-args.scm ├── pathname.scm ├── ports.scm ├── process.scm ├── re-tests.txt ├── record-types.scm ├── streams.scm ├── string-utils.scm ├── sysutils.scm ├── table.scm ├── tests.scm ├── xvector.scm └── zipper-tree.scm /.gitignore: -------------------------------------------------------------------------------- 1 | /spells/foreign/config.sls 2 | /spells/compiled/*.zo 3 | /spells/compiled/*.dep 4 | /spells/*/compiled/*.zo 5 | /spells/*/compiled/*.dep 6 | 7 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | # -*- org -*- 2 | 3 | Project Maintainer: Andreas Rottmann 4 | 5 | In the following, the files of the spells project are listed, grouped 6 | by copyright holders and licenses; roughly following the DEP-5 7 | proposed syntax (http://dep.debian.net/deps/dep5/). 8 | 9 | 10 | # Library 11 | 12 | Copyright: 2005-2010, Andreas Rottmann 13 | Files: * 14 | License: BSD 15 | 16 | Copyright: 1993-2003, Richard Kelsey and Jonathan Rees 17 | 1994-2003, Olin Shivers and Brian D. Carlstrom 18 | 1999-2003, Martin Gasbichler 19 | 2001-2003, Michael Sperber 20 | Files: spells/field-readers.sls, 21 | spells/awk/helpers.sls, 22 | spells/opt-args.sls, 23 | spells/delimited-readers.sls 24 | License: BSD 25 | 26 | Copyright: Copyright, 1993-2008 Richard Kelsey and Jonathan Rees 27 | Files: spells/private/condition.scm 28 | License: BSD 29 | 30 | Copyright: 2007-2009, Taylor R. Campbell 31 | Files: spells/record-types/expand-drt.scm, 32 | spells/private/foof-loop.scm, spells/private/nested-foof-loop.scm, 33 | spells/private/xvector.scm, tests/xvector.scm 34 | License: BSD 35 | 36 | Copyright: 2002, Anthony Carrico 37 | 2009, 2010, Andreas Rottmann 38 | Files: spells/args-fold.sls 39 | License: BSD 40 | 41 | Copyright: 2005-2007, Jose Antonio Ortega Ruiz 42 | Files: spells/opt-args.sls, spells/sysutils/compat.mzscheme.sls 43 | License: BSD 44 | 45 | Copyright: 2003, Kenneth A Dickey. All Rights Reserved. 46 | Files: spells/private/format.scm 47 | License: MIT 48 | 49 | 50 | # Test suite 51 | 52 | Copyright: 2005-2009, Andreas Rottmann 53 | Files: tests/* 54 | License: BSD 55 | 56 | Copyright: 2002, Sebastian Egner 57 | Al Petrofky 58 | Files: spells/private/cut.scm 59 | License: PD 60 | 61 | Copyright: 2002, Sebastian Egner 62 | Files: tests/cut.scm 63 | License: MIT 64 | 65 | Copyright: Alex Shinn 66 | Files: test/match.scm 67 | License: TODO 68 | 69 | -------------------------------------------------------------------------------- /COPYING.BSD: -------------------------------------------------------------------------------- 1 | Copyright (c) 2007, 2008, 2009 by various authors; refer to the file 2 | AUTHORS for a list. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | * Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | * Neither the names of the authors nor the names of contributors may 18 | be used to endorse or promote products derived from this software 19 | without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 22 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 23 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 24 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 26 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 30 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | ;; -*- text -*- 2 | 3 | spells doesn't have GNU-style ChangeLog, but you can use git to obtain 4 | change logs: 5 | 6 | % git clone git://github.com/rotty/spells.git 7 | % cd spells 8 | % git whatchanged 9 | 10 | You can also browse the changes via a web interface at 11 | . 12 | 13 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | - No news yet, just started hacking 2 | -------------------------------------------------------------------------------- /NOTES: -------------------------------------------------------------------------------- 1 | # -*- org -*- 2 | 3 | * Before release 4 | 5 | *** TODO Check README 6 | 7 | Ensure that instructions in README work as advertised. 8 | 9 | *** TODO Clarify licensing 10 | 11 | - List all authors an used licenses, and the respective files, at least. 12 | 13 | - Probably relicense to BSD. 14 | 15 | *** TODO Improve documentation 16 | 17 | Documentation should at least be sufficient to make spells usable for 18 | other people without poking around in the source tree. 19 | 20 | This depends on getting stexidoc up to speed again, and clarifying how 21 | it interacts with implementation-specific files. 22 | 23 | *** TODO Finishing up the R6RS adaption of Riastradh's testing framework 24 | 25 | This is nearly done. 26 | 27 | The test suite itself needs a bit of coverage, especially the restarts 28 | part of it (which should be reviewed, and moved into seperate 29 | library). 30 | 31 | *** TODO Review libraries 32 | 33 | - Move the stuff in ~misc~ to more appropriate places. 34 | 35 | - Likewise for ~assert~. Probably move ~tracing~ to ~debug~, and move 36 | ~cout~ and ~cerr~ from ~assert~ there. Maybe dump or rename the 37 | ~assert~ macro, as R6RS provides this (although it is not 38 | compatible). 39 | 40 | - Fix ~include~ to use ~read-annotated~, where available (this will 41 | finally give source positions for errors in included files). 42 | 43 | - Implement a portable pretty-printer in ~pretty-print.sls~ or ensure 44 | we use the implementation-provided one on all supported 45 | implementations. 46 | 47 | - Probably rename ~weak-pointer~ to ~weak-cell~. 48 | 49 | *** TODO Investigate testsuite errors 50 | 51 | There's a bug in the streams.scm tests on Ypsilon. Probably a Ypsilon 52 | bug. 53 | 54 | * Things to think about 55 | 56 | ** (spells opt-args) 57 | 58 | Do we really need to have so many optional argument macros (except 59 | to support legacy code?). Actually, inside spells, I think I'll 60 | forbid use of anything except DEFINE/OPTIONAL-ARGS. 61 | 62 | ** (spells foreign) 63 | 64 | Naming issues: 65 | 66 | - =ptr= vs =pointer= 67 | - =dlsym= and =dlopen= 68 | - The C type names might be better off using no shortened prefixes 69 | 70 | The =dlerror= API is kind of ugly; probably a condition should be 71 | raised instead. 72 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | # -*- org -*- 2 | 3 | * Spells -- A Scheme portability library 4 | 5 | Spells is a collection of R6RS libraries providing features beyond 6 | R6RS in a uniform way across supported implementations. 7 | 8 | * Documentation 9 | 10 | Please see docs/index.org for some documentation in Emacs org-mode 11 | (i.e. basically plain-text) format. You can also view this 12 | documentation in HTML form at http://rotty.xx.vu/software/spells/. 13 | 14 | * License 15 | 16 | Spells includes code written by various authors, mostly licensed under 17 | the BSD and other free-software, non-copyleft licenses. See the file 18 | AUTHORS for a summary. 19 | 20 | -- 21 | Andreas Rottmann , 2009-07-15 22 | -------------------------------------------------------------------------------- /docs/index.org: -------------------------------------------------------------------------------- 1 | #+SETUPFILE: ~/.emacs.d/org-templates/level-2.org 2 | #+TITLE: spells 3 | 4 | * About 5 | 6 | Spells[fn:1] is a collection of R6RS libraries intended to provide 7 | access to common (but non-standardized) features of Scheme 8 | implementations in a uniform way, hence easing the task of writing 9 | useful programs and libraries that work across several 10 | implementations[fn:2]. 11 | 12 | While you can use Spells "on its own" on a supported implementation, 13 | by creating appropriate symlinks so your implementation can find the 14 | library files, there is a companion project, called SPE, which makes 15 | this a bit easier[fn:3]. It's basically a shell script and a bit of 16 | Scheme code that handles the symlinking and environment-variable 17 | tweaking for you. 18 | 19 | * Status 20 | 21 | Spells has been tested on Ikarus and Ypsilon. It currently provides 22 | the following libraries, beyond ones that implement features readily 23 | coded using only R6RS functionality: 24 | 25 | - (spells filesys) :: File system interface 26 | - (spells foreign) :: Foreign function interface -- call C functions 27 | directly from Scheme, using an Ikarus-style, but 28 | implementation-independent FFI. 29 | - (spells process) :: Operating-System processes 30 | 31 | * Prerequistes 32 | 33 | Spells works with Ikarus (from bzr) and Ypsilon (from SVN). 34 | 35 | # <> 36 | - Ikarus Notes :: A recent bzr checkout (>= 1854) should work out of 37 | the box. 38 | 39 | - Ypsilon Notes :: The latest SVN checkout of Ypsilon should work 40 | out of the box. 41 | 42 | You'll need the ~git~ and ~bzr~ revision control systems, as ~spells~ 43 | itself is managed with git, and depends on the [[https://code.launchpad.net/~scheme-libraries-team/scheme-libraries/srfi][SRFI collection]], which 44 | is using ~bzr~. 45 | 46 | Additionally, if you want to use the ~(spells foreign)~ library, 47 | you'll need a the ~gcc~ C compiler, which is used during the build to 48 | figure out the size of the C types on your platform. 49 | 50 | * Installation 51 | 52 | The recommended way to use spells is with [[http://rotty.yi.org/software/spe][SPE]]. Download SPE, and run 53 | the ~fetch-systems~ script, which will fetch spells and the SRFI 54 | collection, and then run the test suite (subsitute ~ypsilon~ below for 55 | your implementation): 56 | 57 | #+BEGIN_SRC sh 58 | git clone git://github.com/rotty/spe.git 59 | cd spe 60 | ./scripts/fetch-systems ypsilon 61 | ./scripts/launch ypsilon test spells 62 | #+END_SRC 63 | 64 | If you do get errors, please [[mailto:a.rottmann@gmx.at%3Fsubject%3D%5Bspells%20bug%5D][drop me a mail]]. 65 | 66 | * Footnotes 67 | 68 | [fn:1] "spells" can by read as an acronym: Spell's a Portability 69 | Environment Library for Lots of Schemes 70 | 71 | [fn:2] Note that the R6RS version of Spells is a recent reincarnation, 72 | the old (R5RS) Spells has been abandoned. 73 | 74 | [fn:3] Again, the old (R5RS) SPE, which created modules for the target 75 | implementations module system, has been abandoned. 76 | -------------------------------------------------------------------------------- /docs/spells.scm: -------------------------------------------------------------------------------- 1 | ;; About the document 2 | (name "Spells") 3 | (version "0.0.1") 4 | (description "Portability and Utility Library") 5 | (updated "28 May 2011") 6 | (authors 7 | ("Andreas Rottmann" . "a.rottmann@gmx.at")) 8 | 9 | ;; Copying the documentation 10 | (copyright-holder 11 | "Andreas Rottmann, Taylor Campbell, Richard Kelsey, Jonathan Rees, " 12 | "and Mike Sperber") 13 | 14 | (years 2004 2005 2006 2007 2008 2009 2010 2011) 15 | (permissions 16 | "Permission is granted to copy, distribute and/or modify this document 17 | under the terms of the GNU General Public License, Version 3 or any 18 | later version published by the Free Software Foundation.") 19 | 20 | ;; Texinfo info 21 | (texinfo-basename "spells") 22 | (texinfo-category "The Algorithmic Language Scheme") 23 | 24 | ;; Libraries to document 25 | (libraries 26 | "Operating System Interfaces" 27 | ((spells pathname) "Pathname abstraction") 28 | ((spells filesys) "Interacting with the file system") 29 | ((spells process) "Launching OS processes") 30 | ((spells foreign) "Interfacing with C libraries") 31 | ((spells network) "Simple TCP networking") 32 | 33 | "Language Facilities" 34 | ((spells include) "Include Scheme code from other files") 35 | ((spells define-values) "Multiple-value " (code "define")) 36 | ;;((spells delimited-control) "Delimited control operators") 37 | ((spells match) "Pattern matching") 38 | ((spells operations) "T-style dynamic dispatch") 39 | ((spells opt-args) "Define procedures with optional arguments") 40 | ((spells awk) "SCSH's awk macro") 41 | ((spells gc) "Interface to the garbage collector") 42 | ((spells tracing) "A debugging aid") 43 | 44 | "Data Types" 45 | ((spells algebraic-types) "Algebraic data types") 46 | ((spells finite-types) "Types with a fixed number of instances") 47 | ((spells xvector) "Extensible vectors") 48 | ((spells zipper-tree) "Purely functional trees") 49 | ((spells alist) "Association list utilities") 50 | ((spells cells) "Single-value, mutable cells") 51 | ((spells string-utils) "Procedures operating on strings") 52 | 53 | "Miscellany" 54 | ((spells logging) "Hierarchical logging facility")) 55 | -------------------------------------------------------------------------------- /examples/zcat.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (import (rnrs) 4 | (spells ports) 5 | (spells gzip)) 6 | 7 | (define (main argv) 8 | (call-with-port (standard-output-port) 9 | (lambda (stdout) 10 | (for-each (lambda (fname) 11 | (call-with-port (open-gz-file-input-port fname) 12 | (lambda (in) 13 | (copy-port in stdout)))) 14 | (cdr argv))))) 15 | 16 | (main (command-line)) 17 | -------------------------------------------------------------------------------- /pkg-list.scm: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) 2010, 2011, 2012 Andreas Rottmann 2 | 3 | ;; This program is free software, you can redistribute it and/or 4 | ;; modify it under the terms of the new-style BSD license. 5 | 6 | ;; You should have received a copy of the BSD license along with this 7 | ;; program. If not, see . 8 | 9 | 10 | ;;; Main libraries 11 | 12 | (package (spells (0)) 13 | 14 | (depends 15 | (srfi-1) 16 | (srfi-2) 17 | (srfi-8) 18 | (srfi-9) 19 | (srfi-13) 20 | (srfi-14) 21 | (srfi-19) 22 | (srfi-26) 23 | (srfi-27) 24 | (srfi-38) 25 | (srfi-39) 26 | (srfi-43) 27 | (srfi-67) 28 | (srfi-98) 29 | (wak-irregex) 30 | (wak-foof-loop) 31 | (wak-fmt) 32 | (wak-trc-testing)) 33 | 34 | (synopsis "portability and utility library") 35 | (description 36 | "A portability library. It offers a single interface to" 37 | "functionality commonly present, but not standardized, in various" 38 | "Scheme implementations." 39 | "" 40 | "Spells currently offers:" 41 | " - A filesystem interface" 42 | " - A pathname facility" 43 | " - An interface to OS processes" 44 | " - A simple interface to TCP sockets" 45 | " - Weak cells" 46 | " - An implementation of the zipper data structure" 47 | " - Extensible vectors") 48 | (homepage "http://rotty.yi.org/software/spells/") 49 | 50 | (stexidoc "docs/spells.scm") 51 | 52 | (libraries 53 | (exclude ("spells" "foreign") 54 | ("spells" "foreign.sls") 55 | ("spells" "gzip.sls") 56 | ("spells" "private" "stexidoc.sls")) 57 | ("spells" . sls)) 58 | (library-auxiliaries 59 | ("spells" "private"))) 60 | 61 | 62 | ;;; Foreign-function interface 63 | 64 | (package (spells-foreign (0)) 65 | 66 | (depends 67 | (srfi-1) 68 | (srfi-8) 69 | (spells) 70 | (wak-foof-loop) 71 | (conjure)) 72 | 73 | (synopsis "foreign function interface to C") 74 | (description 75 | "An foreign function interface that allows Scheme code" 76 | "to interact with code (libraries) written in C.") 77 | (homepage "http://rotty.yi.org/software/spells/") 78 | 79 | (libraries 80 | ("spells" "foreign" . sls) 81 | ("spells" "foreign.sls")) 82 | 83 | (conjure 84 | (import (rnrs base) 85 | (spells foreign conjure)) 86 | 87 | (foreign-conjure-tasks)) 88 | 89 | (installation-hook ((needs-source? . #t)) 90 | (import (rnrs) 91 | (spells pathname) 92 | (spells foreign conjure) 93 | (conjure dsl) 94 | (conjure dorodango)) 95 | 96 | (make-conjure-hook 97 | (lambda (agent) 98 | (let ((config-pathname (->pathname 99 | '(("spells" "foreign") "config.sls")))) 100 | (task install 101 | (ordinary 102 | (depends 'configure) 103 | (proc (lambda (self) 104 | (let ((product (pathname-join ((self 'project) 'product-dir) 105 | config-pathname))) 106 | (agent 'install-file 107 | 'libraries 108 | (->namestring config-pathname) 109 | (->namestring product))))))) 110 | 111 | (foreign-conjure-tasks)))))) 112 | 113 | ;; Local Variables: 114 | ;; scheme-indent-styles: (pkg-list conjure-dsl) 115 | ;; End: 116 | -------------------------------------------------------------------------------- /spells/algebraic-types.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; algebraic-types.sls --- EOPL-style algebraic datatypes 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Algebraic data types. The syntax provided in this library allows 19 | ;; for concise creation of a number of record types that are 20 | ;; considered to be ``variants'' of a common (abstract) type. Besides 21 | ;; facilitating creation of these related record types, the library 22 | ;; also offers a convenient way to dispatch and destructure instances 23 | ;; thereof. 24 | (library (spells algebraic-types) 25 | (export define-datatype cases) 26 | (import (rnrs) 27 | (for (spells algebraic-types helpers) expand)) 28 | 29 | ;;@defspec define-datatype name variant-clause ... 30 | ;; 31 | ;; Defines an algebraic data type identified by @var{name}. Each 32 | ;; @var{variant-clause}, which has the syntax @code{(@var{variant} 33 | ;; (@var{field} ...))}, defines a record type as with R6RS' 34 | ;; @code{define-record-type} using its implicit accessor naming 35 | ;; scheme. Consider this example: 36 | ;; 37 | ;; @lisp 38 | ;; (define-datatype 39 | ;; (if-expression (test consequent alternative)) 40 | ;; (application (operator operands))) 41 | ;; @end lisp 42 | ;; 43 | ;; This will lead to the creation of two record types, named 44 | ;; @code{if-expression} and @code{application}, with associated 45 | ;; constructors and accessors such as @code{make-if-expression} and 46 | ;; @code{application-operands}. 47 | ;; 48 | ;;@end defspec 49 | (define-syntax define-datatype 50 | (lambda (stx) 51 | (syntax-case stx () 52 | ((k name (variant (field ...)) ...) 53 | #'(begin 54 | (define-record-type variant 55 | (fields field ...)) 56 | ... 57 | (define-syntax name 58 | (expand-datatype-dispatcher 59 | (syntax->datum #'name) 60 | (syntax->datum #'((variant field ...) ...))))))))) 61 | 62 | ;;@defspec cases datatype expression clause ... 63 | ;; 64 | ;; Dispatch on instances of the record types created by 65 | ;; @ref{define-datatype}; first @var{expression} is evaluated, and the 66 | ;; result is checked against each @var{clause}. A @var{clause} may 67 | ;; specify a a variant, with the syntax @code{((@var{variant} 68 | ;; @var{field} ...) body ...)}. When the value of @var{expression} is 69 | ;; an instance of @var{variant}, @var{body} is evaluated in the scope 70 | ;; of the identifiers given by as @var{field}; each @var{field} 71 | ;; identifier is bound to the corresponding field of the record 72 | ;; instance. 73 | ;; 74 | ;; Additionally, an clause ``else'' with syntax @code{(else @var{body} 75 | ;; ...)} may be given as last clause. If none of the variants 76 | ;; specified in the other clauses produces a match, the @var{body} of 77 | ;; the else clause evaluated. If there is no match and no ``else'' 78 | ;; clause, an assertion violation is raised. 79 | ;; 80 | ;;@end defspec 81 | (define-syntax cases 82 | (syntax-rules () 83 | ((_ datatype expr clause ...) 84 | (datatype "cases" expr clause ...)))) 85 | 86 | ) 87 | 88 | -------------------------------------------------------------------------------- /spells/algebraic-types/helpers.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (spells algebraic-types helpers) 4 | (export expand-datatype-dispatcher) 5 | (import (for (rnrs) run (meta -1)) 6 | (spells string-utils) 7 | (spells syntax-utils)) 8 | 9 | (define (cond-clause k name variants variant-clause lose) 10 | (syntax-case variant-clause (else) 11 | (((variant field ...) body0 body ...) 12 | (let* ((variant-sym (syntax->datum #'variant)) 13 | (variant-def (assq variant-sym variants))) 14 | (unless variant-def 15 | (lose (list "{0} is not a variant of datatype {1}" variant-sym name) 16 | variant-clause)) 17 | (with-syntax 18 | (((field-binding ...) 19 | (map (lambda (field-id field-name) 20 | #`(#,field-id (#,(identifier-append k #'variant "-" field-name) 21 | value))) 22 | #'(field ...) 23 | (cdr variant-def)))) 24 | #`((#,(identifier-append k #'variant "?") value) 25 | (let (field-binding ...) 26 | body0 body ...))))) 27 | ((else body0 body ...) 28 | variant-clause))) 29 | 30 | (define (expand-datatype-dispatcher name variants) 31 | (lambda (stx) 32 | (syntax-case stx () 33 | ((k "cases" expr variant-clause ...) 34 | (let ((lose 35 | (lambda (message subform) 36 | (syntax-violation 'cases 37 | (string-substitute (car message) (cdr message)) 38 | stx 39 | subform))) 40 | (have-else? (find (lambda (clause) 41 | (syntax-case clause (else) 42 | ((else . rest) #t) 43 | (_ #f))) 44 | #'(variant-clause ...)))) 45 | (with-syntax (((clause ...) 46 | (map (lambda (clause) 47 | (cond-clause #'k name variants clause lose)) 48 | #'(variant-clause ...))) 49 | (else-clause-maybe 50 | (if have-else? 51 | #'() 52 | #'((else 53 | (assertion-violation 'cases 54 | "no matching clause for value" 55 | value)))))) 56 | #'(let ((value expr)) 57 | (cond clause ... . else-clause-maybe)))))))) 58 | 59 | ) 60 | -------------------------------------------------------------------------------- /spells/alist.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; alist.sls --- R6RS library providing alist utilities. 3 | 4 | ;; Copyright (C) 2009-2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Association list utilities. 19 | (library (spells alist) 20 | (export acons 21 | assq-ref assv-ref assoc-ref 22 | let-assq) 23 | (import (for (rnrs base) run expand) 24 | (for (rnrs syntax-case) expand) 25 | (for (rnrs lists) run expand) 26 | (for (srfi :8 receive) expand)) 27 | 28 | ;;@ Return the alist @3 extended by @code{(cons @1 @2)}. 29 | (define (acons key val alist) 30 | (cons (cons key val) alist)) 31 | 32 | ;;@ Return the @code{cdr} of the entry in the alist @1 referred to by 33 | ;; @2 or @code{#f} if no such entry exists. 34 | (define (assq-ref alist key) 35 | (cond ((assq key alist) => cdr) (else #f))) 36 | (define (assv-ref alist key) 37 | (cond ((assv key alist) => cdr) (else #f))) 38 | (define (assoc-ref alist key) 39 | (cond ((assoc key alist) => cdr) (else #f))) 40 | 41 | ;;@stop 42 | 43 | (define-syntax let-assq 44 | (lambda (stx) 45 | (define (valid-binding? b) 46 | (syntax-case b () 47 | ((id key) (and (identifier? #'id) (identifier? #'key)) #t) 48 | (id (identifier? #'id) #t) 49 | (_ #f))) 50 | (syntax-case stx () 51 | ((_ alist-expr (binding ...) body ...) 52 | (for-all valid-binding? #'(binding ...)) 53 | (with-syntax (((let-binding ...) 54 | (map (lambda (b) 55 | (receive (id key) 56 | (syntax-case b () 57 | ((id key) 58 | (values #'id #'key)) 59 | (id 60 | (values #'id #'id))) 61 | #`(#,id (assq-ref alist '#,key)))) 62 | #'(binding ...)))) 63 | #'(let ((alist alist-expr)) 64 | (let (let-binding ...) 65 | body ...))))))) 66 | 67 | ) 68 | -------------------------------------------------------------------------------- /spells/array-search.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; array-search.sls --- Search algorithms for array-like data 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells array-search) 19 | (export 20 | make-array-binary-search 21 | make-array-equal-range 22 | 23 | vector-binary-search 24 | vector-equal-range 25 | ) 26 | (import (rnrs) 27 | (srfi :67 compare-procedures)) 28 | 29 | (define (make-array-binary-search array-ref array-length) 30 | (define binary-search 31 | (case-lambda 32 | ((array value cmp k) 33 | (let loop ((start 0) 34 | (end (array-length array)) 35 | (j #f)) 36 | (let ((i (div (+ start end) 2))) 37 | (if (or (= start end) (and j (= i j))) 38 | #f 39 | (let* ((elt (array-ref array i)) 40 | (result (cmp elt value))) 41 | (if3 result 42 | (loop i end i) 43 | (k i elt) 44 | (loop start i i))))))) 45 | ((array value cmp) 46 | (binary-search array value cmp (lambda (i elt) i))))) 47 | binary-search) 48 | 49 | (define (make-array-equal-range array-ref array-length) 50 | (define equal-range 51 | (case-lambda 52 | ((array value cmp k) 53 | (define (lower-bound start end) 54 | (let loop ((start start) 55 | (end end)) 56 | (let ((i (div (+ start end) 2))) 57 | (if (= start end) 58 | start 59 | (if? (cmp (array-ref array i) value) 69 | (loop start i) 70 | (loop (+ i 1) end)))))) 71 | (let loop ((left 0) 72 | (right (array-length array))) 73 | (let ((i (div (+ left right) 2))) 74 | (if (= left right) 75 | (k left right) 76 | (if3 (cmp (array-ref array i) value) 77 | (loop (+ i 1) right) 78 | (k (lower-bound left i) 79 | (upper-bound i right)) 80 | (loop left i)))))) 81 | ((array value cmp) 82 | (equal-range array value cmp values)))) 83 | equal-range) 84 | 85 | (define vector-binary-search 86 | (make-array-binary-search vector-ref vector-length)) 87 | 88 | (define vector-equal-range 89 | (make-array-equal-range vector-ref vector-length)) 90 | 91 | ) 92 | -------------------------------------------------------------------------------- /spells/ascii.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;;@ ASCII encoding utilities. 4 | (library (spells ascii) 5 | (export char->ascii ascii->char 6 | ascii-limit ascii-whitespaces 7 | ascii-upper? ascii-lower? 8 | ascii-uppercase ascii-lowercase) 9 | (import (rnrs base) 10 | (rnrs control) 11 | (spells include)) 12 | 13 | (include-file ((spells private) ascii))) 14 | -------------------------------------------------------------------------------- /spells/assert.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (spells assert) 4 | (export assert cerr cout) 5 | (import (except (rnrs base) assert) 6 | (rnrs io ports) 7 | (rnrs io simple) 8 | (spells include)) 9 | 10 | (include-file ((spells private) assert))) 11 | -------------------------------------------------------------------------------- /spells/awk.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; awk.sls --- AWK loop macro 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; An awk loop, after the design of David Albertz and Olin Shivers. 17 | 18 | ;;; Code: 19 | 20 | 21 | ;;@ SCSH's awk macro. 22 | (library (spells awk) 23 | (export awk) 24 | (import (rnrs) 25 | (only (srfi :1) append-map) 26 | (srfi :8 receive) 27 | (for (spells awk helpers) run expand)) 28 | 29 | ;;@defspec awk next-record (record field ...) state-vars . clauses 30 | ;;@defspecx awk next-record (record field ...) counter state-vars . clauses 31 | ;; 32 | ;; See 33 | ;; @uref{http://www.scsh.net/docu/html/man-Z-H-9.html#node_sec_8.2, 34 | ;; the SCSH manual}. 35 | ;; 36 | ;;@end defspec 37 | (define-syntax awk 38 | (lambda (stx) 39 | (syntax-case stx () 40 | ((_ next-record 41 | (record field ...) 42 | counter 43 | ((state-var init-expr) ...) 44 | clause ...) 45 | (identifier? #'counter) 46 | (let*-values (((clauses) (map parse-clause #'(clause ...))) 47 | ((svars) #'(state-var ...)) 48 | ((clauses rx-bindings) 49 | (optimize-clauses clauses))) 50 | (with-syntax (((after-body ...) (get-after-body clauses svars)) 51 | ((range-var ...) (get-range-vars clauses)) 52 | ((rx-binding ...) rx-bindings)) 53 | #`(let ((reader (lambda () next-record)) 54 | rx-binding ...) 55 | (let ^loop-var ((counter 0) 56 | (state-var init-expr) ... 57 | (range-var #f) ...) 58 | (receive (record field ...) (reader) 59 | (cond ((eof-object? record) 60 | after-body ...) 61 | (else 62 | #,@(expand-loop-body #'record 63 | #'counter 64 | #'(range-var ...) 65 | svars 66 | clauses))))))))) 67 | 68 | ;; Left out counter... 69 | ((_ next-record 70 | (record field ...) 71 | ((state-var init-expr) ...) 72 | clause ...) 73 | #'(awk next-record 74 | (record field ...) 75 | counter 76 | ((state-var init-expr) ...) 77 | clause ...))))) 78 | 79 | ) 80 | 81 | ;; Local Variables: 82 | ;; scheme-indent-styles: (foof-loop) 83 | ;; End: 84 | -------------------------------------------------------------------------------- /spells/awk/range-tests.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; range-tests.sls --- Range test procedures for the AWK macro 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells awk range-tests) 19 | (export next-range next-:range 20 | next-range: next-:range:) 21 | (import (rnrs base)) 22 | 23 | 24 | ;;; These procs are for handling RANGE clauses. 25 | 26 | ;; First return value tells whether this line is active; 27 | ;; next value tells whether region is active after this line. 28 | ;; 29 | ;; (:range 0 4) = 0 1 2 3 This is the most useful one. 30 | ;; (range: 0 4) = 1 2 3 4 31 | ;; (range 0 4) = 1 2 3 32 | ;; (:range: 0 4) = 0 1 2 3 4 33 | 34 | ;; If these were inlined and the test thunks substituted, it would 35 | ;; be acceptably efficient. But who writes Scheme compilers that good 36 | ;; in the 90's? 37 | 38 | (define (next-:range start-test stop-test state) 39 | (let ((new-state (if state 40 | (or (not (stop-test)) ; Stop, 41 | (start-test)) ; but restart. 42 | 43 | (and (start-test) ; Start, 44 | (not (stop-test)))))) ; but stop, too. 45 | (values new-state new-state))) 46 | 47 | (define (next-range: start-test stop-test state) 48 | (values state 49 | (if state 50 | (or (not (stop-test)) ; Stop, 51 | (start-test)) ; but restart. 52 | (and (start-test) ; Start, 53 | (not (stop-test)))))) ; but stop, too. 54 | 55 | (define (next-range start-test stop-test state) 56 | (if state 57 | (let ((not-stop (not (stop-test)))) 58 | (values not-stop 59 | (or not-stop ; Stop, 60 | (start-test)))) ; but restart. 61 | (values #f 62 | (and (start-test) ; Start, 63 | (not (stop-test)))))) ; but stop, too. 64 | 65 | (define (next-:range: start-test stop-test state) 66 | (if state 67 | (values #t 68 | (or (not (stop-test)) ; Stop 69 | (start-test))) ; but restart. 70 | 71 | (let ((start? (start-test))) 72 | (values start? 73 | (and start? ; Start, 74 | (not (stop-test))))))) ; but stop, too. 75 | ) 76 | -------------------------------------------------------------------------------- /spells/cells.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; cells.sls --- Implementation of the cells datatype in terms of records 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; Heavyweight (but portable) implementation of cells. 17 | 18 | ;;; Code: 19 | 20 | ;;@ Mutable cells. 21 | (library (spells cells) 22 | (export make-cell cell? cell-ref cell-set!) 23 | (import (rnrs base) 24 | (srfi :9 records)) 25 | 26 | ;;@defun make-cell value 27 | ;; Create a cell containing @var{value}. 28 | ;;@end defun 29 | 30 | ;;@defun cell? thing 31 | ;; Return @code{#t} if @var{thing} is a cell. 32 | ;;@end defun 33 | 34 | ;;@defun cell-ref cell 35 | ;; Return the contents of @var{cell}. 36 | ;;@end defun 37 | 38 | ;;@defun cell-set! cell value 39 | ;; Set the contents of @var{cell} to @var{value}. 40 | ;;@end defun 41 | 42 | (define-record-type cell 43 | (make-cell value) 44 | cell? 45 | (value cell-ref cell-set!))) 46 | 47 | ;;; cells.sls ends here 48 | -------------------------------------------------------------------------------- /spells/condition.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; condition.sls --- Extra condition types 3 | 4 | ;; Copyright (C) 2008, 2009, 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Additional condition types. 19 | (library (spells condition) 20 | (export &parser-error make-parser-error parser-error? 21 | parser-error-port 22 | &stacked make-stacked-condition stacked-condition? next-condition 23 | 24 | dsp-condition 25 | display-condition 26 | 27 | ;; This doesn't really belong here 28 | limited-write) 29 | (import (rnrs) 30 | (wak foof-loop) 31 | (wak fmt) 32 | (spells include)) 33 | 34 | (include-file ((spells private) condition))) 35 | -------------------------------------------------------------------------------- /spells/define-values.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; define-values.sls --- define-values syntax. 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; This program is free software, you can redistribute it and/or 7 | ;; modify it under the terms of the new-style BSD license. 8 | 9 | ;; You should have received a copy of the BSD license along with this 10 | ;; program. If not, see . 11 | 12 | ;;; Commentary: 13 | 14 | ;;; Code: 15 | 16 | ;;@ Define multiple identifiers using the results of a single 17 | ;; expression. 18 | (library (spells define-values) 19 | (export define-values) 20 | (import (for (rnrs base) run expand) 21 | (for (rnrs syntax-case) run expand)) 22 | 23 | ;;@defspec define-values (name ...) body ... 24 | ;; 25 | ;; Defines the identifiers given by @var{name} @dots{} by using the 26 | ;; values returned by @var{body}. 27 | ;; 28 | ;;@end defspec 29 | (define-syntax define-values 30 | (lambda (form) 31 | ;; The temporaries generated for `dummy' are just a workaround 32 | ;; for a psyntax bug in Guile. 33 | (syntax-case form () 34 | ((_ () exp ...) 35 | (with-syntax (((dummy) (generate-temporaries '(dummy)))) 36 | (syntax 37 | (define dummy (begin exp ... 'dummy))))) 38 | ((_ (id ...) exp0 exp ...) 39 | ;; Mutable-ids are needed so that ids defined by 40 | ;; define-values can be exported from a library (mutated 41 | ;; variables cannot be exported). This fix is due to Andre 42 | ;; van Tonder. 43 | (with-syntax (((mutable-id ...) (generate-temporaries (syntax (id ...)))) 44 | ((result ...) (generate-temporaries (syntax (id ...)))) 45 | ((dummy) (generate-temporaries '(dummy)))) 46 | (syntax 47 | (begin 48 | (define mutable-id) ... 49 | (define dummy 50 | (call-with-values 51 | (lambda () exp0 exp ...) 52 | (lambda (result ...) 53 | (set! mutable-id result) ... 54 | 'dummy))) 55 | (define id mutable-id) ...)))))))) 56 | -------------------------------------------------------------------------------- /spells/delimited-control.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; delimited-control.sls --- Delimited-control operators 3 | 4 | ;; Copyright (C) 2009, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; Code taken from http://okmij.org/ftp/Scheme/delim-control-n.scm; 17 | ;; - Changed to use R6RS records instead of mutable pairs 18 | ;; - Use macrology to define all 4 operator pairs 19 | 20 | ;;; Code: 21 | 22 | ;;@ Delimited control operators. 23 | (library (spells delimited-control) 24 | (export abort 25 | prompt control shift reset 26 | prompt0 control0 shift0 reset0) 27 | (import (rnrs base) 28 | (rnrs records syntactic)) 29 | 30 | ; This is one single global mutable cell 31 | (define holes '()) 32 | 33 | (define (hole-push! hole) (set! holes (cons hole holes))) 34 | (define (hole-pop!) (let ((hole (car holes))) (set! holes (cdr holes)) hole)) 35 | 36 | (define-record-type (cell cell-new cell?) 37 | (fields (immutable v cell-ref) 38 | (immutable mark cell-marked?))) 39 | 40 | ; Essentially this is the ``return from the function'' 41 | (define (abort-top! v) ((cell-ref (hole-pop!)) v)) 42 | 43 | (define (unwind-till-marked! who keep?) 44 | (if (null? holes) 45 | (assertion-violation who "No prompt set")) 46 | (let ((hole (hole-pop!))) 47 | (if (cell-marked? hole) ; if marked, it's prompt's hole 48 | (begin (hole-push! ; put it back 49 | (if keep? 50 | hole 51 | (cell-new (cell-ref hole) #f))) ; make the hole non-delimiting 52 | '()) 53 | (cons hole (unwind-till-marked! who keep?))))) 54 | 55 | (define (prompt* thunk) 56 | (call-with-current-continuation 57 | (lambda (outer-k) 58 | (hole-push! (cell-new outer-k #t)) ; it's prompt's hole 59 | (abort-top! (thunk))))) 60 | 61 | (define (make-control* who shift? keep?) 62 | (lambda (f) 63 | (call-with-current-continuation 64 | (lambda (k-control) 65 | (let* ((holes-prefix (reverse (unwind-till-marked! who keep?))) 66 | (invoke-subcont 67 | (lambda (v) 68 | (call-with-current-continuation 69 | (lambda (k-return) 70 | (hole-push! (cell-new k-return shift?)) 71 | (for-each hole-push! holes-prefix) 72 | (k-control v)))))) 73 | (abort-top! (f invoke-subcont))))))) 74 | 75 | (define-syntax define-operators 76 | (syntax-rules () 77 | ((_ (control* control prompt) shift? keep?) 78 | (begin 79 | (define control* (make-control* 'control shift? keep?)) 80 | 81 | ;; Some syntactic sugar 82 | (define-syntax prompt 83 | (syntax-rules () 84 | ((prompt e) (prompt* (lambda () e))))) 85 | 86 | (define-syntax control 87 | (syntax-rules () 88 | ((control k e) (control* (lambda (k) e))))))))) 89 | 90 | (define-operators (shift* shift reset) #t #t) 91 | (define-operators (shift0* shift0 reset0) #t #f) 92 | 93 | (define-operators (control* control prompt) #f #t) 94 | (define-operators (control0* control0 prompt0) #f #f) 95 | 96 | (define (abort v) (control* (lambda (k) v))) 97 | 98 | ) 99 | -------------------------------------------------------------------------------- /spells/engines.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; engines.sls --- Nestable "engines" 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; This is a variation of the nestable engines from the paper "Engines 17 | ;; from Continuations", by R. Kent Dybvig and Robert Hieb, 1988. 18 | 19 | ;;; Code: 20 | (library (spells engines) 21 | (export make-engine) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (spells engines timer)) 25 | 26 | (define make-engine 27 | (let ((stack '())) 28 | 29 | (define (new-engine proc id) 30 | (lambda (ticks return expire) 31 | ((call/cc 32 | (lambda (k) 33 | (run proc 34 | (stop-timer) 35 | ticks 36 | (lambda (value ticks engine-maker) 37 | (k (lambda () (return value ticks engine-maker)))) 38 | (lambda (engine) 39 | (k (lambda () (expire engine)))) 40 | id)))))) 41 | 42 | (define (run resume parent child return expire id) 43 | (let ((ticks (if (and (active?) (< parent child)) parent child))) 44 | (push (- parent ticks) (- child ticks) return expire id) 45 | (resume ticks))) 46 | 47 | (define (go ticks) 48 | (when (active?) 49 | (if (= ticks 0) 50 | (timer-handler) 51 | (start-timer ticks timer-handler)))) 52 | 53 | (define (do-return proc value ticks id1) 54 | (pop 55 | (lambda (parent child return expire id2) 56 | (cond ((eq? id1 id2) 57 | (go (+ parent ticks)) 58 | (return value 59 | (+ child ticks) 60 | (lambda (value) 61 | (new-engine (proc value) id1)))) 62 | (else 63 | (do-return 64 | (lambda (value) 65 | (lambda (new-ticks) 66 | (run (proc value) new-ticks (+ child ticks) return expire id2))) 67 | value 68 | (+ parent ticks) 69 | id1)))))) 70 | 71 | (define (do-expire resume) 72 | (pop (lambda (parent child return expire id) 73 | (cond ((> child 0) 74 | (do-expire (lambda (ticks) 75 | (run resume ticks child return expire id)))) 76 | (else 77 | (go parent) 78 | (expire (new-engine resume id))))))) 79 | 80 | (define (timer-handler) 81 | (go (call/cc do-expire))) 82 | 83 | (define (push . l) 84 | (set! stack (cons l stack))) 85 | (define (pop handler) 86 | (if (null? stack) 87 | (error 'engine "attempt to return from inactive engine") 88 | (let ((top (car stack))) 89 | (set! stack (cdr stack)) 90 | (apply handler top)))) 91 | (define (active?) 92 | (not (null? stack))) 93 | 94 | (lambda (proc) 95 | (letrec ((engine-return 96 | (lambda (value) 97 | (call/cc 98 | (lambda (k) 99 | (do-return (lambda (value) 100 | (lambda (ticks) 101 | (go ticks) 102 | (k value))) 103 | value 104 | (stop-timer) 105 | engine-return)))))) 106 | (new-engine (lambda (ticks) 107 | (go ticks) 108 | (proc engine-return) 109 | (error 'engine "invalid completion")) 110 | engine-return))))) 111 | 112 | ) 113 | -------------------------------------------------------------------------------- /spells/engines/timer.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; timer.sls --- Engine timer interface 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells engines timer) 19 | (export start-timer stop-timer decrement-timer) 20 | (import (rnrs base) 21 | (rnrs control) 22 | (srfi :39 parameters)) 23 | 24 | (define current-clock (make-parameter 0)) 25 | (define current-handler (make-parameter #f)) 26 | 27 | (define (start-timer ticks new-handler) 28 | (current-handler new-handler) 29 | (current-clock ticks)) 30 | 31 | (define (stop-timer) 32 | (let ((time-left (current-clock))) 33 | (current-clock 0) 34 | time-left)) 35 | 36 | (define (decrement-timer) 37 | (let ((new-clock (- (current-clock) 1))) 38 | (when (>= new-clock 0) 39 | (current-clock new-clock) 40 | (when (= new-clock 0) 41 | ((current-handler)))))) 42 | 43 | ) 44 | -------------------------------------------------------------------------------- /spells/error.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; error.sls --- Error handling utilities. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ @uref{http://srfi.schemers.org/srfi-23/srfi-23.html, SRFI 23} 19 | ;; compatability library. 20 | (library (spells error) 21 | (export error error-who make-error-signaller) 22 | (import 23 | (rename (rnrs base) (error rnrs:error)) 24 | (srfi :39 parameters)) 25 | 26 | (define error-who (make-parameter #f)) 27 | 28 | (define (error . args) 29 | (apply rnrs:error (error-who) args)) 30 | 31 | (define (make-error-signaller who) 32 | (lambda args 33 | (apply rnrs:error who args)))) 34 | -------------------------------------------------------------------------------- /spells/filesys/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;;; compat.larceny.sls --- File system operations for Larceny. 2 | 3 | ;; Copyright (C) 2009 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Commentary: 14 | 15 | ;;; Code: 16 | 17 | 18 | (library (spells filesys compat) 19 | (export file-exists? 20 | create-directory 21 | delete-file 22 | rename-file 23 | 24 | file-regular? 25 | file-directory? 26 | file-symbolic-link? 27 | file-readable? 28 | file-writable? 29 | file-executable? 30 | file-modification-time 31 | file-size-in-bytes 32 | 33 | directory-fold* 34 | 35 | working-directory 36 | with-working-directory 37 | 38 | copy-file) 39 | (import (rnrs base) 40 | (rnrs conditions) 41 | (srfi :8 receive) 42 | (spells pathname) 43 | (primitives parameterize) 44 | (prefix (primitives file-exists? 45 | current-directory 46 | delete-file) 47 | la:)) 48 | 49 | (define ->fn ->namestring) 50 | 51 | (define (file-exists? pathname) 52 | (la:file-exists? (->fn pathname))) 53 | 54 | (define (create-directory pathname) 55 | (error 'directory-fold* "please implement me for larceny")) 56 | 57 | (define (delete-file pathname) 58 | ;; FIXME: doesn't work for directories 59 | (if (file-exists? pathname) 60 | (la:delete-file (->fn pathname)))) 61 | 62 | (define (rename-file source-pathname target-pathname) 63 | (error 'rename-file "please implement me for larceny")) 64 | 65 | (define (file-regular? pathname) 66 | (error 'file-regular? "please implement me for larceny")) 67 | 68 | (define (file-symbolic-link? pathname) 69 | (error 'file-symbolic-link? "please implement me for larceny")) 70 | 71 | (define (file-directory? pathname) 72 | (error 'file-directory? "please implement me for larceny")) 73 | 74 | (define (file-readable? pathname) 75 | (error 'file-readable? "please implement me for larceny")) 76 | (define (file-writable? pathname) 77 | (error 'file-writable? "please implement me for larceny")) 78 | (define (file-executable? pathname) 79 | (error 'file-executable? "please implement me for larceny")) 80 | 81 | (define (file-modification-time pathname) 82 | (error 'file-modification-time "please implement me for larceny")) 83 | 84 | (define (file-size-in-bytes pathname) 85 | (error 'file-size-in-bytes "please implement me for larceny")) 86 | 87 | (define (directory-fold* pathname combiner . seeds) 88 | (error 'directory-fold* "please implement me for larceny")) 89 | 90 | (define (working-directory) 91 | (->pathname (la:current-directory))) 92 | 93 | (define (with-working-directory dir thunk) 94 | (parameterize ((la:current-directory 95 | (->fn (pathname-as-directory (->pathname dir))))) 96 | (thunk))) 97 | 98 | (define (copy-file old-file new-file) 99 | (error 'copy-file "please implement me for larceny")) 100 | 101 | ) 102 | -------------------------------------------------------------------------------- /spells/foreign/config.sls.in: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; config.sls.in --- FFI platform configuration. 3 | 4 | ;; Copyright (C) 2009, 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; This file is intended to be processed by conjure's configure 17 | ;; mechanism, substituting the placeholders. 18 | 19 | ;;; Code: 20 | 21 | (library (spells foreign config) 22 | (export c-type-sizeof c-type-alignof) 23 | (import (rnrs base) 24 | (rnrs lists)) 25 | 26 | (define (c-type-sizeof sym) 27 | (let ((size 28 | (case sym 29 | ((char uchar int8 uint8) 1) 30 | ((int16 uint16) 2) 31 | ((int32 uint32) 4) 32 | ((int64 uint64) 8) 33 | ((short ushort) #!@(c-sizeof short)) 34 | ((int uint) #!@(c-sizeof int)) 35 | ((long ulong) #!@(c-sizeof long)) 36 | ((llong ullong) #!@(c-sizeof (long long))) 37 | ((pointer) #!@(c-sizeof (void *))) 38 | ((float) #!@(c-sizeof float)) 39 | ((double) #!@(c-sizeof double)) 40 | ((size_t ssize_t) #!@(c-sizeof size_t "stddef.h")) 41 | ((time_t) #!@(c-sizeof time_t "time.h")) 42 | (else #f)))) 43 | (or size 44 | (assertion-violation 'c-type-sizeof 45 | "size of type unknown" sym)))) 46 | 47 | (define (c-type-alignof sym) 48 | (let ((alignment 49 | (case sym 50 | ((char uchar int8 uint8) #!@(c-alignof char)) 51 | ((int16 uint16) #!@(c-alignof int16_t "stdint.h")) 52 | ((int32 uint32) #!@(c-alignof int32_t "stdint.h")) 53 | ((int64 uint64) #!@(c-alignof int64_t "stdint.h")) 54 | ((short ushort) #!@(c-alignof short)) 55 | ((int uint) #!@(c-alignof int)) 56 | ((long ulong) #!@(c-alignof long)) 57 | ((llong ullong) #!@(c-alignof (long long))) 58 | ((pointer) #!@(c-alignof (void *))) 59 | ((float) #!@(c-alignof float)) 60 | ((double) #!@(c-alignof double)) 61 | ((size_t ssize_t) #!@(c-alignof size_t "stddef.h")) 62 | ((time_t) #!@(c-alignof time_t "time.h")) 63 | (else #f)))) 64 | (or alignment 65 | (assertion-violation 'c-type-alignof 66 | "alignment of type unknown" sym))))) 67 | 68 | ;; Local Variables: 69 | ;; mode: scheme 70 | ;; End: 71 | -------------------------------------------------------------------------------- /spells/foreign/conjure.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; conjure.sls --- Conjure tasks for the FFI 3 | 4 | ;; Copyright (C) 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells foreign conjure) 19 | (export foreign-conjure-tasks) 20 | (import (rnrs) 21 | (conjure cc) 22 | (conjure hostinfo) 23 | (conjure dsl)) 24 | 25 | (define (foreign-conjure-tasks) 26 | (task configure 27 | (configure 28 | (produce `((("spells" "foreign") "config.sls") 29 | <= (("spells" "foreign") "config.sls.in"))) 30 | (fetchers (cc-fetcher 'cc) 31 | (hostinfo-fetcher)))) 32 | 33 | (task cc (cc-conf)) 34 | 35 | ) 36 | 37 | ) 38 | 39 | ;; Local Variables: 40 | ;; scheme-indent-styles: (conjure-dsl) 41 | ;; End: 42 | -------------------------------------------------------------------------------- /spells/foreign/frozen-bytes.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; frozen-bytes.sls --- 3 | 4 | ;; Copyright (C) 2009, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells foreign frozen-bytes) 19 | (export freeze-bytes 20 | unfreeze-bytes 21 | frozen-bytes-pointer) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (rnrs bytevectors) 25 | (rnrs records syntactic) 26 | (spells foreign compat)) 27 | 28 | 29 | (define-record-type frozen-bytes 30 | (fields ptr bv start len)) 31 | 32 | (define freeze-bytes 33 | (case-lambda 34 | ((direction bv start end) 35 | (let ((len (- end start))) 36 | (case direction 37 | ((in) 38 | (memcpy (malloc len) 0 bv start len)) 39 | ((out) 40 | (make-frozen-bytes (malloc len) bv start len)) 41 | ((inout) 42 | (make-frozen-bytes (memcpy (malloc len) 0 bv start len) 43 | bv start len)) 44 | (else 45 | (error 'freeze-bytes "invalid direction" direction))))) 46 | ((direction bv start) 47 | (freeze-bytes direction bv start (bytevector-length bv))) 48 | ((direction bv) 49 | (freeze-bytes direction bv 0 (bytevector-length bv))))) 50 | 51 | (define (frozen-bytes-pointer x) 52 | (if (frozen-bytes? x) 53 | (frozen-bytes-ptr x) 54 | x)) 55 | 56 | (define (unfreeze-bytes x) 57 | (cond ((frozen-bytes? x) 58 | (memcpy (frozen-bytes-bv x) (frozen-bytes-start x) 59 | (frozen-bytes-ptr x) 0 (frozen-bytes-len x)) 60 | (free (frozen-bytes-ptr x))) 61 | (else 62 | (free x)))) 63 | 64 | ) 65 | -------------------------------------------------------------------------------- /spells/foreign/util.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; util.sls --- Foreign function interface internal utilities 3 | 4 | ;; Copyright (C) 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | (library (spells foreign util) 15 | (export sized-integer-type 16 | other-type-aliases) 17 | (import (rnrs) 18 | (spells foreign config)) 19 | 20 | (define sized-integer-type 21 | (let ((who 'sized-integer-type)) 22 | (case-lambda 23 | ((ctype signed?) 24 | (case (c-type-sizeof ctype) 25 | ((1) (if signed? 'int8 'uint8)) 26 | ((2) (if signed? 'int16 'uint16)) 27 | ((4) (if signed? 'int32 'uint32)) 28 | ((8) (if signed? 'int64 'uint64)) 29 | (else 30 | (assertion-violation who 31 | "unexpected return value from c-type-sizeof" 32 | ctype)))) 33 | ((ctype) 34 | (let ((signed? (case ctype 35 | ((char short int long llong) #t) 36 | ((uchar ushort uint ulong ullong) #f) 37 | (else 38 | (assertion-violation who 39 | "argument not an integer type" 40 | ctype))))) 41 | (sized-integer-type ctype signed?)))))) 42 | 43 | (define other-type-aliases 44 | `((fpointer . pointer) 45 | (size_t . ,(sized-integer-type 'size_t #f)) 46 | (ssize_t . ,(sized-integer-type 'ssize_t #t)) 47 | ;; we assume time_t to be a signed integer type; this true at 48 | ;; least on glibc systems 49 | (time_t . ,(sized-integer-type 'time_t #t)))) 50 | 51 | ) 52 | -------------------------------------------------------------------------------- /spells/format.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; format.sls --- Common-Lisp-style `format'. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Common-Lisp-style @code{format}. 19 | (library (spells format) 20 | (export format) 21 | (import (except (rnrs base) error) 22 | (rnrs unicode) 23 | (rnrs io ports) 24 | (rnrs io simple) 25 | (rnrs r5rs) 26 | (spells error) 27 | (spells pretty-print) 28 | (srfi :38 with-shared-structure) 29 | (spells include)) 30 | 31 | (define char->ascii char->integer) 32 | (define ascii->char integer->char) 33 | 34 | (include-file ((spells private) format))) 35 | -------------------------------------------------------------------------------- /spells/gc.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; gc.sls --- Interface to the implementation's GC 3 | 4 | ;; Copyright (C) 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | 19 | ;;@ This library exposes an interface to implementation's garbage 20 | ;; collector. 21 | (library (spells gc) 22 | (export make-reaper 23 | make-weak-cell weak-cell-ref weak-cell? 24 | collect) 25 | (import (rnrs base) 26 | (rnrs control) 27 | (spells misc) 28 | (spells gc compat)) 29 | 30 | ;;@subheading Resource reclamation 31 | ;; 32 | ;; The following procedure allows for registration of a set of objects 33 | ;; with the garbage collector, and the execution of an action should 34 | ;; they become eligible for garbage collection. 35 | 36 | ;;@defun make-reaper proc 37 | ;; 38 | ;; Returns a single procedure (a ``reaper'') that accepts zero or, 39 | ;; alternatively, one argument. When passed a single argument, the 40 | ;; reaper will register the argument with the garbage collector. In 41 | ;; this case, the reaper returns unspecified values. 42 | ;; 43 | ;; Calling the reaper with zero arguments may cause @var{proc} to be 44 | ;; applied to an object that has been registered with the garbage 45 | ;; collector via the same reaper, and has become ripe for garbage 46 | ;; collection (i.e. it has become invisible except to the reaper). 47 | ;; The call to the reaper returns the values returned by its 48 | ;; invocation to @var{proc}, or @code{#f} if @var{proc} was not 49 | ;; invoked since no registered object was eligible for collection. 50 | ;; 51 | ;;@end defun 52 | 53 | ;;@subheading Weak cells 54 | ;; 55 | ;; Weak cells are single-value containers referencing some value that 56 | ;; may be garbage collected, even though referenced by the weak cell. 57 | ;; When the value is indeed garbage collected, the reference inside 58 | ;; all weak cells referring to it is "broken", and 59 | ;; @code{weak-cell-ref} for such cells will return @code{#f}. 60 | 61 | ;;@defun make-weak-cell object 62 | ;; 63 | ;; Create a weak cell referencing @var{object}. 64 | ;; 65 | ;;@end defun 66 | 67 | ;;@defun weak-cell-ref weak-cell 68 | ;; 69 | ;; Return the value contained in @var{object}, or @code{#f} if the 70 | ;; value was garbage collected. 71 | ;; 72 | ;;@end defun 73 | 74 | ;;@defun weak-cell? object 75 | ;; 76 | ;; Returns @code{#t} if @var{object} is a weak cell. Note that 77 | ;; disjointness of weak cells is not guaranteed. 78 | ;; 79 | ;;@end defun 80 | 81 | ;;@subheading Triggering garbage collection 82 | ;; 83 | ;; Note that triggering garbage collection is something that should 84 | ;; happen automatically; this interface is provided as a debugging and 85 | ;; testing aid, and should not be used in ``regular'' code. 86 | ;; 87 | 88 | ;;@defun collect 89 | ;; 90 | ;; Trigger a run of the garbage collector. 91 | ;; 92 | ;;@end defun 93 | 94 | ) 95 | -------------------------------------------------------------------------------- /spells/gc/compat.guile.sls: -------------------------------------------------------------------------------- 1 | ;;; compat.guile.sls --- GC-interacting procedures for Guile 2 | 3 | ;; Copyright (C) 2010, 2015 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Commentary: 14 | 15 | ;;; Code: 16 | 17 | 18 | (library (spells gc compat) 19 | (export make-weak-cell weak-cell-ref weak-cell? 20 | make-reaper 21 | collect) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (ice-9 weak-vector) 25 | (only (guile) make-guardian gc)) 26 | 27 | (define (make-weak-cell obj) 28 | ;; Guile seems to have issues with `weak-vector', so we do it this 29 | ;; way 30 | (let ((result (make-weak-vector 1))) 31 | (weak-vector-set! result 0 obj) 32 | result)) 33 | 34 | (define (weak-cell? thing) 35 | (weak-vector? thing)) 36 | 37 | (define (weak-cell-ref weak-cell) 38 | (weak-vector-ref weak-cell 0)) 39 | 40 | (define (make-reaper proc) 41 | (let ((guardian (make-guardian))) 42 | (case-lambda 43 | ((object) 44 | (guardian object)) 45 | (() 46 | (let ((object (guardian))) 47 | (if object 48 | (proc object) 49 | #f)))))) 50 | 51 | (define collect gc) 52 | 53 | ) 54 | -------------------------------------------------------------------------------- /spells/gc/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;;; compat.ikarus.sls --- GC-interacting procedures for Ikarus. 2 | 3 | ;; Copyright (C) 2009 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Commentary: 14 | 15 | ;;; Code: 16 | 17 | 18 | (library (spells gc compat) 19 | (export make-weak-cell weak-cell-ref weak-cell? 20 | make-reaper 21 | collect) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (only (ikarus) 25 | weak-cons weak-pair? bwp-object? make-guardian 26 | collect)) 27 | 28 | (define (make-weak-cell obj) 29 | (weak-cons obj #f)) 30 | 31 | (define (weak-cell? thing) 32 | (weak-pair? thing)) 33 | 34 | (define (weak-cell-ref weak-cell) 35 | (let ((obj (car weak-cell))) 36 | (and (not (bwp-object? obj)) obj))) 37 | 38 | (define (make-reaper proc) 39 | (let ((guardian (make-guardian))) 40 | (case-lambda 41 | ((object) 42 | (guardian object)) 43 | (() 44 | (let ((object (guardian))) 45 | (if object 46 | (proc object) 47 | #f)))))) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /spells/gc/compat.mosh.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; compat.mosh.sls - (spells gc) compatibility layer for Mosh 3 | ; copyright: 2011 David Banks ; license: BSD-3-clause 4 | 5 | (library (spells gc compat) 6 | (export make-weak-cell weak-cell-ref weak-cell? 7 | make-reaper 8 | collect) 9 | (import (rnrs) 10 | (spells misc)) 11 | 12 | ; Mosh doesn't have any weak reference support at the moment. 13 | ; Fake it out. 14 | 15 | (define-record-type weak-cell 16 | (fields object)) 17 | 18 | (define weak-cell-ref weak-cell-object) 19 | 20 | (define (make-reaper proc) 21 | (case-lambda 22 | ((obj) (unspecific)) 23 | (() #f))) 24 | 25 | (define (collect) 26 | (unspecific)) 27 | ) 28 | -------------------------------------------------------------------------------- /spells/gc/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.ikarus.sls --- GC-interacting procedures for PLT Scheme 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells gc compat) 19 | (export make-weak-cell weak-cell-ref weak-cell? 20 | make-reaper 21 | collect) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (rename (only (scheme) 25 | make-weak-box 26 | weak-box-value 27 | weak-box? 28 | 29 | collect-garbage 30 | 31 | make-will-executor 32 | will-register 33 | will-try-execute) 34 | 35 | (make-weak-box make-weak-cell) 36 | (weak-box-value weak-cell-ref) 37 | (weak-box? weak-cell?) 38 | 39 | (collect-garbage collect))) 40 | 41 | (define (make-reaper proc) 42 | (let ((executor (make-will-executor))) 43 | (case-lambda 44 | ((object) 45 | (will-register executor object proc)) 46 | (() 47 | (will-try-execute executor))))) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /spells/gc/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; gc.ypsilon.sls --- GC-interacting procedures for Ypsilon. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells gc compat) 19 | (export make-weak-cell weak-cell-ref weak-cell? 20 | make-reaper 21 | collect) 22 | (import (rnrs base) 23 | (rnrs control) 24 | (spells misc) 25 | (only (core) 26 | make-weak-mapping 27 | weak-mapping? 28 | weak-mapping-key 29 | weak-mapping-value 30 | collect)) 31 | 32 | (define (make-weak-cell obj) 33 | (make-weak-mapping obj #f)) 34 | 35 | (define (weak-cell? thing) 36 | (weak-mapping? thing)) 37 | 38 | (define (weak-cell-ref weak-cell) 39 | (weak-mapping-key weak-cell)) 40 | 41 | ;; Ypsilon does not (yet) support guardians or an equivalent 42 | ;; mechanism, see 43 | ;; http://code.google.com/p/ypsilon/issues/detail?id=75 44 | (define (make-reaper proc) 45 | (case-lambda 46 | ((obj) (unspecific)) 47 | (() #f))) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /spells/hash-utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; hash-utils.sls --- 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells hash-utils) 19 | (export hash-combine 20 | hash-fold) 21 | (import (rnrs base) 22 | (rnrs arithmetic fixnums)) 23 | 24 | (define hash-bits (- (fixnum-width) 1)) 25 | (define hash-mask (fxnot (fxarithmetic-shift -1 hash-bits))) 26 | 27 | (define (hash-combine h1 h2) 28 | (fxxor (fxrotate-bit-field (fxand h1 hash-mask) 0 hash-bits 7) 29 | (fxrotate-bit-field (fxand h2 hash-mask) 0 hash-bits (- hash-bits 6)))) 30 | 31 | (define (hash-fold hasher initial-hash lst) 32 | (let loop ((hash initial-hash) (lst lst)) 33 | (if (null? lst) 34 | hash 35 | (loop (hash-combine hash (hasher (car lst))) 36 | (cdr lst))))) 37 | 38 | ) 39 | -------------------------------------------------------------------------------- /spells/include.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; include.sls --- Include scheme source code. 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ File inclusion of Scheme code. 19 | (library (spells include) 20 | (export include-file 21 | include-file/downcase) 22 | (import (rnrs) 23 | (for (only (spells include compat) 24 | annotation? 25 | annotation-expression) expand) 26 | (for (spells include helpers) expand)) 27 | 28 | ;;@defspec include-file 29 | ;; @lisp 30 | ;; (include-file ((@var{directory-component} @dots{}) @var{file-component}))@end lisp 31 | ;; 32 | ;; Include a the contents of the file specified by the 33 | ;; @var{directory-component}s and @var{file-component} at in the 34 | ;; lexical context of the @code{include-file} form; i.e. the 35 | ;; effect is the same as if the contents of the specified file 36 | ;; (which must be syntactically valid Scheme code) was present 37 | ;; instead of the @code{include-file} form. 38 | ;; 39 | ;;@end defspec 40 | (define-syntax include-file 41 | (lambda (stx) 42 | (syntax-case stx () 43 | ((k ) 44 | (include-file/aux 'include-file #'k (syntax->datum #') values))))) 45 | 46 | ;;@defspec include-file/downcase 47 | ;; 48 | ;; This macro has the same syntax and behavior as 49 | ;; @code{include-file}, but applies case folding to all symbols 50 | ;; appearing in included file's content. This behavior is 51 | ;; especially useful for including R5RS code which exploits the 52 | ;; case-insensitivity of R5RS. 53 | ;; 54 | ;;@end defspec 55 | (define-syntax include-file/downcase 56 | (lambda (stx) 57 | ;; This loses all the annotations, but Ikarus provides no way to 58 | ;; (re-)construct annotation objects ATM. 59 | (define (downcase thing) 60 | (let ((form (if (annotation? thing) 61 | (annotation-expression thing) 62 | thing))) 63 | (cond ((symbol? form) 64 | (string->symbol (string-downcase (symbol->string form)))) 65 | ((pair? form) 66 | (cons (downcase (car form)) 67 | (downcase (cdr form)))) 68 | (else 69 | thing)))) 70 | (syntax-case stx () 71 | ((k ) 72 | (include-file/aux 'include-file #'k (syntax->datum #') downcase))))) 73 | 74 | ) 75 | -------------------------------------------------------------------------------- /spells/include/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.ikarus.sls --- 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells include compat) 19 | (export stale-when 20 | annotation? 21 | annotation-expression 22 | read-annotated) 23 | (import (rnrs base) 24 | (only (ikarus) 25 | stale-when 26 | annotation? 27 | read-annotated 28 | annotation-expression)) 29 | 30 | ) 31 | -------------------------------------------------------------------------------- /spells/include/compat.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.sls --- include compatibility 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells include compat) 19 | (export stale-when 20 | read-annotated 21 | annotation? 22 | annotation-expression) 23 | (import (rnrs base) 24 | (rnrs io simple)) 25 | 26 | (define-syntax stale-when 27 | (syntax-rules () 28 | ((_ conditition body ...) 29 | (begin body ...)))) 30 | 31 | (define (read-annotated port) 32 | (read port)) 33 | 34 | (define (annotation? thing) 35 | #f) 36 | 37 | (define (annotation-expression thing) 38 | thing) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /spells/include/helpers.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; helpers.sls --- Helper procedures for (spells include) 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells include helpers) 19 | (export include-file/aux) 20 | (import (rnrs) 21 | (only (spells time-lib) time-utc->posix-timestamp) 22 | (only (spells filesys) 23 | find-file 24 | file-modification-time 25 | library-search-paths) 26 | (only (spells pathname) ->namestring) 27 | (for (spells include compat) run (meta -1))) 28 | 29 | (define (error/conditions who msg irrts . cndts) 30 | (raise 31 | (apply condition 32 | (make-error) 33 | (make-who-condition who) 34 | (make-message-condition msg) 35 | (make-irritants-condition irrts) 36 | cndts))) 37 | 38 | (define (string-join lst sep) 39 | (if (null? lst) 40 | "" 41 | (let loop ((result '()) (lst lst)) 42 | (if (null? lst) 43 | (apply string-append (cdr (reverse result))) 44 | (loop (cons (car lst) (cons sep result)) 45 | (cdr lst)))))) 46 | 47 | (define (file-mtime filename) 48 | (time-utc->posix-timestamp (file-modification-time filename))) 49 | 50 | (define (filespec->path name) 51 | (cond ((string? name) name) 52 | ((symbol? name) (string-append (symbol->string name) ".scm")) 53 | ((pair? name) (string-append 54 | (if (pair? (car name)) 55 | (string-join (map symbol->string (car name)) "/") 56 | (symbol->string (car name))) 57 | "/" 58 | (symbol->string (cadr name)) 59 | ".scm")) 60 | (else name))) 61 | 62 | (define (include-file/aux who ctxt path transformer) 63 | (let* ((relpath (filespec->path path)) 64 | (pathname (find-file relpath (library-search-paths)))) 65 | (unless pathname 66 | (error 'include-file "cannot find file in search paths" 67 | relpath 68 | (library-search-paths))) 69 | (let ((filename (->namestring pathname))) 70 | (with-exception-handler 71 | (lambda (ex) 72 | (error/conditions who 73 | "error while trying to include" 74 | (list filename) 75 | (if (condition? ex) 76 | ex 77 | (make-irritants-condition (list ex))))) 78 | (lambda () 79 | (call-with-input-file filename 80 | (lambda (port) 81 | (let loop ((x (read-annotated port)) (forms '())) 82 | (if (eof-object? x) 83 | #`(stale-when (or (not (file-exists? #,filename)) 84 | (> (file-mtime #,filename) 85 | #,(file-mtime filename))) 86 | #,@(datum->syntax ctxt (reverse forms))) 87 | (loop (read-annotated port) 88 | (cons (transformer x) forms))))))))))) 89 | 90 | ) 91 | 92 | ;; Local Variables: 93 | ;; scheme-indent-styles: ((stale-when 1)) 94 | ;; End: 95 | -------------------------------------------------------------------------------- /spells/list-utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; list-utils.sls --- List utilities 3 | 4 | ;; Copyright (C) 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | 17 | ;;; Code: 18 | 19 | (library (spells list-utils) 20 | (export list-intersperse 21 | list-prefix) 22 | (import (rnrs)) 23 | 24 | ;;@ Return a new list obtained by inserting @var{elem} between all 25 | ;; elements of @var{lst}. 26 | (define (list-intersperse lst elem) 27 | (if (null? lst) 28 | lst 29 | (let loop ((l (cdr lst)) (result (list (car lst)))) 30 | (if (null? l) 31 | (reverse result) 32 | (loop (cdr l) (cons (car l) (cons elem result))))))) 33 | 34 | ;;@ If the list @var{prefix} is a prefix of the list @var{list}, 35 | ;;return the remainder of elements after stripping @var{prefix} from 36 | ;;@var{list}, else return @code{#f}. 37 | (define (list-prefix prefix list =?) 38 | (let loop ((elt-rest list) 39 | (prefix-rest prefix)) 40 | (cond ((null? prefix-rest) 41 | elt-rest) 42 | ((null? elt-rest) 43 | #f) 44 | ((=? (car elt-rest) (car prefix-rest)) 45 | (loop (cdr elt-rest) (cdr prefix-rest))) 46 | (else 47 | #f)))) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /spells/misc.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; misc.sls --- Misc stuff. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Stuff that doesn't fit somewhere else. 19 | (library (spells misc) 20 | (export identity 21 | compose 22 | unspecific 23 | sleep-seconds 24 | sort-list 25 | and-map 26 | or-map 27 | and=> 28 | topological-sort 29 | scheme-implementation) 30 | (import (rnrs base) 31 | (rnrs lists) 32 | (rnrs io simple) 33 | (rnrs sorting) 34 | (rnrs hashtables) 35 | (spells include) 36 | (spells misc compat)) 37 | 38 | (include-file ((spells private) misc))) 39 | -------------------------------------------------------------------------------- /spells/misc/compat.guile.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.guile.sls --- Misc functions, Guile compatibility 3 | 4 | ;; Copyright (C) 2010, 2012 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells misc compat) 19 | (export sleep-seconds 20 | scheme-implementation) 21 | (import (rnrs base) 22 | (only (guile) usleep)) 23 | 24 | (define (sleep-seconds t) 25 | (usleep (+ (* (exact (truncate t)) #e1e+6) 26 | (mod (exact (round (* t #e1e+6))) #e1e+6)))) 27 | 28 | (define (scheme-implementation) 'guile)) 29 | -------------------------------------------------------------------------------- /spells/misc/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | (library (spells misc compat) 2 | (export sleep-seconds scheme-implementation) 3 | (import (rnrs base) 4 | (only (ikarus) nanosleep)) 5 | 6 | (define (sleep-seconds t) 7 | (nanosleep (exact (truncate t)) (mod (exact (round (* t #e1e+9))) #e1e+9))) 8 | 9 | (define (scheme-implementation) 10 | 'ikarus)) 11 | -------------------------------------------------------------------------------- /spells/misc/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | (library (spells misc compat) 2 | (export sleep-seconds exit scheme-implementation) 3 | (import (rnrs base)) 4 | 5 | (define (sleep-seconds t) 6 | (error 'sleep-seconds "please implement SLEEP-SECONDS for this implementation")) 7 | 8 | (define (exit status) 9 | (error 'exit "please implement EXIT for this implementation")) 10 | 11 | (define (scheme-implementation) 12 | 'larceny)) 13 | -------------------------------------------------------------------------------- /spells/misc/compat.mosh.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; compat.mosh.sls - (spells misc) compatibility layer for Mosh 3 | ; copyright: 2011 David Banks ; license: BSD-3-clause 4 | 5 | (library (spells misc compat) 6 | (export sleep-seconds 7 | scheme-implementation) 8 | (import (rnrs base) 9 | (only (mosh concurrent) sleep)) 10 | 11 | ; Mosh's sleep from concurrent is millisecond accurate 12 | (define (sleep-seconds t) 13 | (sleep (+ (* (exact (truncate t)) #e1e+3) 14 | (mod (exact (round (* t #e1e+3))) #e1e+3)))) 15 | 16 | (define (scheme-implementation) 'mosh)) 17 | -------------------------------------------------------------------------------- /spells/misc/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.mzscheme.sls --- Misc functions, mzscheme compatibility 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells misc compat) 19 | (export sleep-seconds exit scheme-implementation) 20 | (import (rnrs base) 21 | (only (mzscheme) 22 | sleep exit)) 23 | 24 | (define sleep-seconds sleep) 25 | (define (scheme-implementation) 'mzscheme)) 26 | -------------------------------------------------------------------------------- /spells/misc/compat.sls: -------------------------------------------------------------------------------- 1 | (library (spells misc compat) 2 | (export sleep-seconds scheme-implementation) 3 | (import (rnrs base)) 4 | 5 | ;;@ Sleep @1 seconds. 6 | (define (sleep-seconds t) 7 | (error "please implement SLEEP-SECONDS for this implementation")) 8 | 9 | ;;@ Return a symbol indicating the scheme implementation 10 | (define (scheme-implementation) 11 | 'unknown)) 12 | -------------------------------------------------------------------------------- /spells/misc/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | (library (spells misc compat) 2 | (export sleep-seconds scheme-implementation) 3 | (import (rnrs base) 4 | (only (core primitives) usleep)) 5 | 6 | (define (sleep-seconds t) 7 | (usleep (+ (* (exact (truncate t)) #e1e+6) 8 | (mod (exact (round (* t #e1e+6))) #e1e+6)))) 9 | 10 | (define (scheme-implementation) 11 | 'ypsilon)) 12 | -------------------------------------------------------------------------------- /spells/network/compat.guile.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; network.guile.sls --- Network interface, Guile compatibility 3 | 4 | ;; Copyright (C) 2010, 2011, 2013, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells network compat) 19 | (export connection? 20 | connection-input-port 21 | connection-output-port 22 | close-connection 23 | 24 | listener? 25 | listener-accept 26 | listener-address 27 | close-listener 28 | 29 | open-tcp-connection 30 | open-tcp-listener) 31 | (import (rnrs) 32 | (srfi :8 receive) 33 | (spells network utils) 34 | (prefix (only (guile) 35 | PF_INET 36 | SOCK_STREAM 37 | false-if-exception 38 | addrinfo:fam 39 | addrinfo:addr 40 | getaddrinfo 41 | socket 42 | connect 43 | bind 44 | listen 45 | accept 46 | getsockname) 47 | guile:)) 48 | 49 | (define-record-type connection 50 | (fields socket)) 51 | 52 | (define (connection-input-port conn) 53 | (connection-socket conn)) 54 | 55 | (define (connection-output-port conn) 56 | (connection-socket conn)) 57 | 58 | (define (close-connection conn) 59 | (close-port (connection-socket conn))) 60 | 61 | (define-record-type listener 62 | (fields socket)) 63 | 64 | (define (listener-accept listener) 65 | (let ((c (guile:accept (listener-socket listener)))) 66 | (make-connection (car c)))) 67 | 68 | (define (close-listener listener) 69 | (close-port (listener-socket listener))) 70 | 71 | (define (listener-address listener) 72 | (guile:getsockname (listener-socket listener))) 73 | 74 | (define (socket+sockaddr address service) 75 | (cond ((guile:false-if-exception 76 | (car (guile:getaddrinfo address 77 | (cond ((integer? service) 78 | (number->string service)) 79 | ((symbol? service) 80 | (symbol->string service)) 81 | (else 82 | service))))) 83 | => (lambda (ai) 84 | (values (guile:socket (guile:addrinfo:fam ai) 85 | guile:SOCK_STREAM 86 | 0) 87 | (guile:addrinfo:addr ai)))) 88 | (else 89 | (values #f #f)))) 90 | 91 | (define (open-tcp-connection address service) 92 | (receive (socket sockaddr) (socket+sockaddr address service) 93 | (unless sockaddr 94 | (error 'open-tcp-connection 95 | "cannot resolve address or service" 96 | address service)) 97 | (guile:connect socket sockaddr) 98 | (make-connection socket))) 99 | 100 | (define (open-tcp-listener . maybe-options) 101 | (let-options* (if (null? maybe-options) '() (car maybe-options)) 102 | ((service #f) 103 | (address #f)) 104 | (receive (socket sockaddr) (socket+sockaddr address service) 105 | (guile:bind socket sockaddr) 106 | (guile:listen socket 5) 107 | (make-listener socket)))) 108 | 109 | ) 110 | 111 | ;; Local Variables: 112 | ;; scheme-indent-styles: ((let-options* 2)) 113 | ;; End: 114 | -------------------------------------------------------------------------------- /spells/network/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.ikarus.sls --- Network interface, Ikarus compatibility 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells network compat) 19 | (export connection? 20 | connection-input-port 21 | connection-output-port 22 | close-connection 23 | 24 | listener? 25 | listener-accept 26 | listener-address 27 | close-listener 28 | 29 | open-tcp-connection 30 | open-tcp-listener) 31 | (import (rnrs) 32 | (srfi :8 receive) 33 | (spells network utils) 34 | (prefix (only (ikarus) 35 | tcp-server-socket 36 | accept-connection 37 | close-tcp-server-socket 38 | tcp-connect) 39 | ik:)) 40 | 41 | (define-record-type connection 42 | (fields input-port output-port)) 43 | 44 | (define (close-connection conn) 45 | (close-port (connection-input-port conn)) 46 | (close-port (connection-output-port conn))) 47 | 48 | (define-record-type listener 49 | (fields socket)) 50 | 51 | (define (listener-accept listener) 52 | (receive (iport oport) (ik:accept-connection (listener-socket listener)) 53 | (make-connection iport oport))) 54 | 55 | (define (close-listener listener) 56 | (ik:close-tcp-server-socket (listener-socket listener))) 57 | 58 | (define (listener-address listener) 59 | ;; Ikarus doesn't support this yet 60 | #f) 61 | 62 | (define (open-tcp-listener . maybe-options) 63 | (let-options* (if (null? maybe-options) '() (car maybe-options)) 64 | ((service #f)) 65 | (unless service 66 | (raise-impl-restriction 'open-tcp-listener 67 | "ephemeral ports not supported")) 68 | (make-listener (ik:tcp-server-socket service)))) 69 | 70 | (define (open-tcp-connection address service) 71 | (receive (in-port out-port) 72 | (ik:tcp-connect address (cond ((integer? service) 73 | (number->string service)) 74 | ((symbol? service) 75 | (symbol->string service)) 76 | (else 77 | service))) 78 | (make-connection in-port out-port))) 79 | 80 | ) 81 | 82 | ;; Local Variables: 83 | ;; scheme-indent-styles: ((let-options* 2)) 84 | ;; End: 85 | -------------------------------------------------------------------------------- /spells/network/compat.mosh.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; compat.mosh.sls - (spells network) compatibility layer for Mosh 3 | ; copyright: 2011 David Banks ; license: BSD-3-clause 4 | 5 | (library (spells network compat) 6 | (export connection? 7 | connection-input-port 8 | connection-output-port 9 | connection-socket 10 | close-connection 11 | 12 | listener? 13 | listener-accept 14 | listener-address 15 | close-listener 16 | 17 | open-tcp-connection 18 | open-tcp-listener) 19 | 20 | (import (rnrs) 21 | (prefix (mosh socket) mosh:) 22 | (spells network utils)) 23 | 24 | (define-record-type connection 25 | (protocol (lambda (p) 26 | (lambda (socket) 27 | (p 28 | socket 29 | (mosh:socket-port socket) 30 | (mosh:socket-port socket))))) 31 | (fields socket input-port output-port)) 32 | 33 | (define (close-connection conn) 34 | (mosh:socket-close (connection-socket conn))) 35 | 36 | (define-record-type listener 37 | (fields socket)) 38 | 39 | (define (listener-accept listener) 40 | (make-connection (mosh:socket-accept (listener-socket listener)))) 41 | 42 | (define (close-listener listener) 43 | (mosh:socket-close (listener-socket listener))) 44 | 45 | (define (listener-address listener) 46 | ; Mosh doesn't support this yet 47 | #f) 48 | 49 | (define (open-tcp-connection address service) 50 | (make-connection 51 | (mosh:make-client-socket 52 | address 53 | (cond ((integer? service) (number->string service)) 54 | ((symbol? service) (symbol->string service)) 55 | (else service))))) 56 | 57 | (define (open-tcp-listener . maybe-options) 58 | (let-options* (if (null? maybe-options) '() (car maybe-options)) 59 | ((service #f)) 60 | (unless service 61 | (raise-impl-restriction 'open-tcp-listener 62 | "ephemeral ports not supported")) 63 | (make-listener 64 | (mosh:make-server-socket (number->string service))))) 65 | ) 66 | -------------------------------------------------------------------------------- /spells/network/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.mzscheme.sls --- Network interface, PLT compatibility 3 | 4 | ;; Copyright (C) 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells network compat) 19 | (export connection? 20 | connection-input-port 21 | connection-output-port 22 | close-connection 23 | 24 | listener? 25 | listener-accept 26 | listener-address 27 | close-listener 28 | 29 | open-tcp-connection 30 | open-tcp-listener) 31 | (import (rnrs) 32 | (srfi :8 receive) 33 | (spells network utils) 34 | (prefix (scheme tcp) mz:)) 35 | 36 | (define-record-type connection 37 | (fields input-port output-port)) 38 | 39 | (define (close-connection conn) 40 | (close-port (connection-input-port conn)) 41 | (close-port (connection-output-port conn))) 42 | 43 | (define listener? mz:tcp-listener?) 44 | 45 | (define (listener-accept listener) 46 | (receive (iport oport) (mz:tcp-accept listener) 47 | (make-connection iport oport))) 48 | 49 | (define (close-listener listener) 50 | (mz:tcp-close listener)) 51 | 52 | (define (listener-address listener) 53 | ;; PLT doesn't support this 54 | #f) 55 | 56 | (define (open-tcp-listener . maybe-options) 57 | (let-options* (if (null? maybe-options) '() (car maybe-options)) 58 | ((service #f)) 59 | (mz:tcp-listen service))) 60 | 61 | (define (open-tcp-connection address service) 62 | (receive (in-port out-port) 63 | (mz:tcp-connect address service) 64 | (make-connection in-port out-port))) 65 | 66 | ) 67 | 68 | ;; Local Variables: 69 | ;; scheme-indent-styles: ((let-options* 2)) 70 | ;; End: 71 | -------------------------------------------------------------------------------- /spells/network/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; network.ypsilon.sls --- Network interface, Ypsilon compatibility 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells network compat) 19 | (export connection? 20 | connection-input-port 21 | connection-output-port 22 | close-connection 23 | 24 | listener? 25 | listener-accept 26 | listener-address 27 | close-listener 28 | 29 | open-tcp-connection 30 | open-tcp-listener) 31 | (import (rnrs) 32 | (srfi :8 receive) 33 | (spells network utils) 34 | (prefix (ypsilon socket) yp:)) 35 | 36 | (define-record-type connection 37 | (protocol (lambda (p) 38 | (lambda (socket) 39 | (p socket (yp:socket-port socket) (yp:socket-port socket))))) 40 | (fields socket input-port output-port)) 41 | 42 | (define (close-connection conn) 43 | (yp:socket-shutdown (connection-socket conn) yp:SHUT_RDWR)) 44 | 45 | (define-record-type listener 46 | (fields socket)) 47 | 48 | (define (listener-accept listener) 49 | (make-connection (yp:socket-accept (listener-socket listener)))) 50 | 51 | (define (close-listener listener) 52 | (yp:socket-close (listener-socket listener))) 53 | 54 | (define (listener-address listener) 55 | ;; Ypsilon doesn't support this yet 56 | #f) 57 | 58 | (define (open-tcp-connection address service) 59 | (make-connection (yp:make-client-socket address 60 | (cond ((integer? service) 61 | (number->string service)) 62 | ((symbol? service) 63 | (symbol->string service)) 64 | (else 65 | service))))) 66 | 67 | (define (open-tcp-listener . maybe-options) 68 | (let-options* (if (null? maybe-options) '() (car maybe-options)) 69 | ((service #f)) 70 | (unless service 71 | (raise-impl-restriction 'open-tcp-listener 72 | "ephemeral ports not supported")) 73 | (make-listener 74 | (yp:make-server-socket (number->string service))))) 75 | 76 | ) 77 | 78 | ;; Local Variables: 79 | ;; scheme-indent-styles: ((let-options* 2)) 80 | ;; End: 81 | -------------------------------------------------------------------------------- /spells/network/utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; utils.sls --- 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells network utils) 19 | (export option-ref 20 | let-options* 21 | raise-impl-restriction) 22 | (import (rnrs)) 23 | 24 | (define (option-ref alist key default) 25 | (cond ((assq key alist) => cadr) 26 | (else default))) 27 | 28 | (define-syntax let-options* 29 | (syntax-rules () 30 | ((_ opts-expr ((name default) ...) body ...) 31 | (let* ((opts opts-expr) 32 | (name (option-ref opts 'name default)) 33 | ...) 34 | body ...)))) 35 | 36 | (define (raise-impl-restriction who message) 37 | (raise (condition 38 | (make-who-condition who) 39 | (make-implementation-restriction-violation) 40 | (make-message-condition message)))) 41 | 42 | ) 43 | -------------------------------------------------------------------------------- /spells/operations.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; operations.sls --- T-like operations. 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;@ A generic dispatch system similiar to operations in T. 15 | (library (spells operations) 16 | (export object 17 | operation 18 | define-operation 19 | join) 20 | (import (rnrs base) 21 | (rnrs lists) 22 | (only (srfi :1 lists) any) 23 | (spells procedure-annotations)) 24 | 25 | ;; Auxiliary syntax 26 | (define-syntax %method-clauses->handler 27 | (syntax-rules () 28 | ((%method-clauses->handler ((?op . ?params) ?body ...) ...) 29 | (let ((methods (list (cons ?op (lambda ?params ?body ...)) ...))) 30 | (lambda (op) 31 | (cond ((assq op methods) => cdr) 32 | (else #f))))))) 33 | 34 | ;;@defspec object procedure method-clause ... 35 | ;; 36 | ;; Create an object with default handler @var{procedure} and methods 37 | ;; as specified by @var{method-clause} @dots{}. Each 38 | ;; @var{method-clause} must be of the form @code{((@var{op} 39 | ;; . @var{parameters}) @var{body} ...)}, where @var{op} is an 40 | ;; operation as obtained by @code{operation} or 41 | ;; @code{define-operation}. 42 | ;; 43 | ;;@end defspec 44 | (define-syntax object 45 | (syntax-rules () 46 | ((object ?proc ?method-clause ...) 47 | (make-object ?proc (%method-clauses->handler ?method-clause ...))))) 48 | 49 | ;;@stop 50 | 51 | (define (make-object proc handler) 52 | (annotate-procedure 53 | (or proc (lambda args (error 'make-object "object is not applicable"))) handler)) 54 | 55 | ;;@defspec operation default method-clause ... 56 | ;; 57 | ;; Create an operation with default handler @var{default} and methods 58 | ;; as specified by @var{method-clause} @dots{}. The method clauses 59 | ;; take the same form as with @code{operation}. 60 | ;; 61 | ;;@end defspec 62 | (define-syntax operation 63 | (syntax-rules () 64 | ((operation "%named" ?name ?default ?method-clause ...) 65 | (make-operation '?name ?default (%method-clauses->handler ?method-clause ...))) 66 | ((operation ?default ?method-clause ...) 67 | (operation "%named" #f ?default ?method-clause ...)))) 68 | 69 | ;;@stop 70 | 71 | (define (make-operation name default handler) 72 | (letrec ((op (make-object 73 | (lambda (obj . args) 74 | (cond ((and (procedure? obj) ((procedure-annotation obj) op)) 75 | => (lambda (method) 76 | (apply method obj args))) 77 | (default 78 | (apply default obj args)) 79 | (else 80 | (error 'operation 81 | "operation is not available" 82 | obj 83 | (or name op))))) 84 | handler))) 85 | op)) 86 | 87 | ;;@defspec define-operation (name . parameters) body ... 88 | ;;@defspecx define-operation (name . parameters) 89 | ;; 90 | ;; Define @var{name} as an operation with a default handler with the 91 | ;; argument list @var{parameters} and the body @var{body}. If there 92 | ;; is no @var{body}, the operation will not have a default handler. 93 | ;; 94 | ;;@end defspec 95 | (define-syntax define-operation 96 | (syntax-rules () 97 | ((define-operation (?name . ?args)) 98 | (define ?name (operation "%named" ?name #f))) 99 | ((define-operation (?name . ?args) ?body1 ?body ...) 100 | (define ?name (operation "%named" ?name (lambda ?args ?body1 ?body ...)))))) 101 | 102 | ;;@ Create a compound object from @var{object1} and @var{objects}. 103 | ;; The returned object will respond to any operation defined on 104 | ;; @var{object1} or @var{objects}; operations are resolved in the 105 | ;; order of @code{join}'s arguments. If there is no matching operation 106 | ;; found, @var{object1}'s default handler will be invoked, if any. 107 | (define (join object1 . objects) 108 | (make-object object1 109 | (lambda (op) 110 | (let ((method (any (lambda (o) ((procedure-annotation o) op)) 111 | (cons object1 objects)))) 112 | (or method 113 | (error 'join "operation not available" objects op)))))) 114 | 115 | ) 116 | -------------------------------------------------------------------------------- /spells/pathname/os-string.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; os-string.sls --- Operating-system string abstraction. 3 | 4 | ;; Copyright (C) 2008-2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; Handles OS-strings as used by MzScheme. 17 | 18 | ;;; Code: 19 | 20 | (library (spells pathname os-string) 21 | (export os-string? 22 | os-string->string) 23 | (import (rnrs base) 24 | (only (mzscheme) path? path->string)) 25 | 26 | 27 | (define os-string? path?) 28 | (define (os-string->string os-string) 29 | (path->string os-string)) 30 | 31 | ) 32 | -------------------------------------------------------------------------------- /spells/pathname/os-string.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; os-string.sls --- Operating-system string abstraction. 3 | 4 | ;; Copyright (C) 2008-2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;; This is the generic file, which assumes that OS strings are just 17 | ;; plain strings. If the host implementation handles these 18 | ;; differently, a dialect-specific implementation must be provided. 19 | 20 | ;;; Code: 21 | 22 | (library (spells pathname os-string) 23 | (export os-string? 24 | os-string->string) 25 | (import (rnrs base)) 26 | 27 | (define os-string? string?) 28 | (define (os-string->string os-string) 29 | os-string) 30 | 31 | ) 32 | -------------------------------------------------------------------------------- /spells/pretty-print.ikarus.sls: -------------------------------------------------------------------------------- 1 | (library (spells pretty-print) 2 | (export pretty-print) 3 | (import (rnrs base) 4 | (only (ikarus) pretty-print))) -------------------------------------------------------------------------------- /spells/pretty-print.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; pretty-print.sls --- Pretty-print S-expressions. 3 | 4 | ;; Copyright (C) 2009, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ A simple pretty-printer for S-expressions. 19 | (library (spells pretty-print) 20 | (export pretty-print) 21 | (import (rnrs base) 22 | (srfi :38 with-shared-structure)) 23 | 24 | ;;@defun pretty-print object [ port ] 25 | ;; Ouput a pretty-printed representation of @var{object} to @var{port}, 26 | ;; which defaults to @code{(current-output-port)}. 27 | ;;@end defun 28 | (define (pretty-print object . port-opt) 29 | (apply write-with-shared-structure object port-opt))) 30 | 31 | -------------------------------------------------------------------------------- /spells/private/ascii.scm: -------------------------------------------------------------------------------- 1 | ;;; ascii.scm --- ASCII encoding. 2 | 3 | ;; Copyright (C) 2009 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Commentary: 14 | 15 | ;;; Code: 16 | 17 | ;;@ Converts an ASCII code (integer) into the corresponding 18 | ;; character. 19 | (define (ascii->char n) 20 | (unless (< -1 n ascii-limit) 21 | (error 'ascii->char "number outside of ASCII range" n)) 22 | (integer->char n)) 23 | 24 | ;;@ Converts the character @1 into the corresponding ASCII code. 25 | (define (char->ascii c) 26 | (let ((n (char->integer c))) 27 | (unless (< -1 n ascii-limit) 28 | (error 'char->ascii "non-ASCII character" c)) 29 | n)) 30 | 31 | (define ascii-limit 128) 32 | 33 | ;;@ List of integers that are considered white-space. 34 | (define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return 35 | 36 | (define ascii-lowercase-a (char->ascii #\a)) 37 | (define ascii-uppercase-a (char->ascii #\A)) 38 | 39 | ;;@ Check whether @1 is in the upper/lower case range of ASCII. 40 | (define (ascii-upper? n) (<= ascii-lowercase-a n 90)) 41 | (define (ascii-lower? n) (<= ascii-uppercase-a 122)) 42 | 43 | ;;@ Return the ASCII code of the lower/upper-case version of the 44 | ;; character represented by @1 or @1 itself if @1 does not correspond 45 | ;; to an upper/lower-case character. 46 | (define (ascii-lowercase n) 47 | (if (ascii-upper? n) 48 | (+ (- n ascii-uppercase-a) ascii-lowercase-a) 49 | n)) 50 | (define (ascii-uppercase n) 51 | (if (ascii-lower? n) 52 | (+ (- n ascii-lowercase-a) ascii-uppercase-a) 53 | n)) 54 | 55 | ;;; ascii.scm ends here 56 | -------------------------------------------------------------------------------- /spells/private/assert.scm: -------------------------------------------------------------------------------- 1 | ;;; assert.scm --- Assertations and debugging aids. 2 | 3 | ;; Copyright (C) 2009 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann , based on code taken 6 | ;; from SSAX, written by Oleg Kiselyov and placed in the public 7 | ;; domain. 8 | 9 | ;; This program is free software, you can redistribute it and/or 10 | ;; modify it under the terms of the new-style BSD license. 11 | 12 | ;; You should have received a copy of the BSD license along with this 13 | ;; program. If not, see . 14 | 15 | ;;; Commentary: 16 | 17 | ;;; Code: 18 | 19 | ;;@ Assert the truth of an expression (or of a sequence of expressions). 20 | ;; 21 | ;; syntax: @code{assert @var{?expr} @var{?expr} ... [report: @var{?r-exp} @var{?r-exp} 22 | ;; ...]} 23 | ;; 24 | ;; If @code{(and @var{?expr} @var{?expr} ...)} evaluates to anything but 25 | ;; @code{#f}, the result is the value of that expression. Otherwise, an 26 | ;; error is reported. 27 | ;; 28 | ;; The error message will show the failed expressions, as well as the 29 | ;; values of selected variables (or expressions, in general). The user may 30 | ;; explicitly specify the expressions whose values are to be printed upon 31 | ;; assertion failure -- as @var{?r-exp} that follow the identifier 32 | ;; @code{report:}. 33 | ;; 34 | ;; Typically, @var{?r-exp} is either a variable or a string constant. If 35 | ;; the user specified no @var{?r-exp}, the values of variables that are 36 | ;; referenced in @var{?expr} will be printed upon the assertion failure. 37 | ;; 38 | (define-syntax assert 39 | (syntax-rules (report:) 40 | ((assert "doit" (expr ...) (r-exp ...)) 41 | (cond 42 | ((and expr ...) => (lambda (x) x)) 43 | (else 44 | (error 'assert "assertion failure" (list '(and expr ...) r-exp ...))))) 45 | ((assert "collect" (expr ...)) 46 | (assert "doit" (expr ...) ())) 47 | ((assert "collect" (expr ...) report: r-exp ...) 48 | (assert "doit" (expr ...) (r-exp ...))) 49 | ((assert "collect" (expr ...) expr1 stuff ...) 50 | (assert "collect" (expr ... expr1) stuff ...)) 51 | ((assert stuff ...) 52 | (assert "collect" () stuff ...)))) 53 | 54 | ;;@ Invoke @code{display} all elements of @1, except for procedures, 55 | ;; which are called with no arguments instead of being 56 | ;; @code{display}ed. 57 | (define (cout . args) 58 | (for-each (lambda (x) 59 | (if (procedure? x) (x) (display x))) 60 | args)) 61 | 62 | 63 | ;;@ Invoke @code{(display x (current-error-port))} all elements @var{x} 64 | ;; of @1, except for procedures, which are called with 65 | ;; @code{(current-error-port)} as single argument instead of being 66 | ;; @code{display}ed. 67 | (define (cerr . args) 68 | (for-each (lambda (x) 69 | (if (procedure? x) 70 | (x (current-error-port)) 71 | (display x (current-error-port)))) 72 | args)) 73 | 74 | ;; arch-tag: 4e369d8c-f537-4a45-94eb-7815b53bc510 75 | -------------------------------------------------------------------------------- /spells/private/gc.scm: -------------------------------------------------------------------------------- 1 | ;;@ Create a weak pointer to @1. 2 | (define (make-weak-cell obj) (proc-to-be-defined)) 3 | 4 | ;;@ Return the value contained in @1, or @code{#f} if the value was 5 | ;; garbage collected. 6 | (define (weak-cell-ref weak-cell) (proc-to-be-defined)) 7 | 8 | ;;@ Returns @code{#t} if @1 is a weak pointer. Note that disjointness 9 | ;; of weak pointers is not guaranteed. 10 | (define (weak-cell? thing) (proc-to-be-defined)) 11 | -------------------------------------------------------------------------------- /spells/private/misc.scm: -------------------------------------------------------------------------------- 1 | ;; misc.scm -- Utilities that don't fit elsewhere 2 | 3 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Comentary: 14 | 15 | ;; Miscellaneous utility functions. 16 | 17 | ;;; Code: 18 | 19 | ;;@ Efficiently sort the list @1 using the comparison function 20 | ;; @2. Stability is not required. 21 | (define (sort-list lst cmpf) 22 | (list-sort cmpf lst)) 23 | 24 | ;;@ Returns the `unspecific' value, as normally returned by e.g. code 25 | ;; @code{(if #f #f)}. 26 | (define (unspecific) 27 | (if #f #f)) 28 | 29 | ;;@ Apply @1 to @2 (like map) and apply @code{and} to the 30 | ;; resulting list. 31 | (define (and-map proc lst) 32 | (let loop ((lst lst) (res #t)) 33 | (cond ((null? lst) res) 34 | (res (loop (cdr lst) (and res (proc (car lst))))) 35 | (else #f)))) 36 | 37 | ;;@ Apply @1 to @2 (like map) and apply @code{or} to the 38 | ;; resulting list. 39 | (define (or-map proc lst) 40 | (let loop ((lst lst) (res #f)) 41 | (cond ((null? lst) res) 42 | (res res) 43 | (else (loop (cdr lst) (or res (proc (car lst)))))))) 44 | 45 | ;;@ The identity function, returning @1. 46 | (define (identity x) x) 47 | 48 | ;;@ Compose two procedures, yielding a procedure of the same arity 49 | ;; as @2. 50 | (define (compose f g) (lambda args (f (apply g args)))) 51 | 52 | (define (and=> e proc) 53 | (and e (proc e))) 54 | 55 | 56 | 57 | 58 | ;; `topological-sort' based on code written by Peter Danenberg, 59 | ;; (re-)licensed with his permission to new-style BSD. 60 | 61 | ;;@ Topologically sort @var{graph}, according to the equality function 62 | ;; @var{maybe-eql}, which defaults to @code{eqv?}. 63 | (define (topological-sort graph . maybe-eql) 64 | (let* ((eql? (if (pair? maybe-eql) (car maybe-eql) eqv?)) 65 | (make-table (cond ((eq? eql? eq?) 66 | make-eq-hashtable) 67 | ((eq? eql? eqv?) 68 | make-eqv-hashtable) 69 | ((eq? eql? string=?) 70 | (lambda () 71 | (make-hashtable string-hash eql?))) 72 | (else 73 | (lambda () 74 | (make-hashtable equal-hash eql?)))))) 75 | (let ((vertices (make-table)) 76 | (discovered (make-table))) 77 | (define (discovered? vertex) 78 | (hashtable-ref discovered vertex #f)) 79 | (define (set-discovered! vertex) 80 | (hashtable-set! discovered vertex #t)) 81 | (define (visit parent sorted) 82 | (set-discovered! parent) 83 | (cons parent 84 | (fold-left (lambda (sorted child) 85 | (if (discovered? child) 86 | sorted 87 | (visit child sorted))) 88 | sorted 89 | (hashtable-ref vertices parent '())))) 90 | (for-each (lambda (entry) 91 | (hashtable-set! vertices (car entry) (cdr entry))) 92 | graph) 93 | (fold-left (lambda (sorted entry) 94 | (let ((vertex (car entry))) 95 | (if (discovered? vertex) 96 | sorted 97 | (visit vertex sorted)))) 98 | '() 99 | graph)))) 100 | 101 | ;;; misc.scm ends here 102 | -------------------------------------------------------------------------------- /spells/private/skip-char-set.scm: -------------------------------------------------------------------------------- 1 | ;;; skip-char-set.scm --- Skip characters from a set in a port. 2 | 3 | ;; Copyright (C) 2009 Andreas Rottmann 4 | 5 | ;; Author: Andreas Rottmann 6 | 7 | ;; This program is free software, you can redistribute it and/or 8 | ;; modify it under the terms of the new-style BSD license. 9 | 10 | ;; You should have received a copy of the BSD license along with this 11 | ;; program. If not, see . 12 | 13 | ;;; Commentary: 14 | 15 | ;;; Code: 16 | 17 | (define (skip-char-set skip-chars . maybe-port) 18 | (let* ((port (:optional maybe-port (current-input-port))) 19 | (cset (->char-set skip-chars))) 20 | 21 | (if (not (input-port? port)) 22 | (error "Illegal value -- not an input port." port)) 23 | 24 | ;; Mighty slow -- we read each char twice (peek first, then read). 25 | (let lp ((i 0)) 26 | (let ((c (lookahead-char port))) 27 | (cond ((and (char? c) (char-set-contains? cset c)) 28 | (get-char port) 29 | (lp (+ i 1))) 30 | (else i)))))) 31 | -------------------------------------------------------------------------------- /spells/private/stexidoc.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; stexidoc.sls --- stexidoc extractors 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells private stexidoc) 19 | (export spells-extractors 20 | foreign-extractors) 21 | (import (rnrs) 22 | (spells match) 23 | (stexidoc extract) 24 | (stexidoc reader)) 25 | 26 | (define (foreign:define-extractor form) 27 | (match (cdr (strip-non-forms form)) 28 | ((name ('make-pointer-c-getter type)) 29 | `((procedure (^ (name ,name) (arguments pointer offset))))) 30 | (else 31 | #f))) 32 | 33 | (define (%->string x) 34 | (if (string? x) x (symbol->string x))) 35 | 36 | (define (symbol-append . syms) 37 | (string->symbol (apply string-append (map %->string syms)))) 38 | 39 | (define (defrectype*-extractor form) 40 | (match (cdr (strip-non-forms form)) 41 | ((name (constructor . fields) extra-fields) 42 | (let ((predicate (symbol-append name "?"))) 43 | `((procedure (^ (name ,predicate) (arguments "object"))) 44 | (procedure (^ (name ,name) (arguments ,@fields))) 45 | ,@(map (lambda (field) 46 | `(procedure (^ (name ,(symbol-append name '- field)) 47 | (arguments ,name)))) 48 | fields)))) 49 | (else 50 | #f))) 51 | 52 | (define spells-extractors 53 | (extend-extractors usual-spedl-extractors 54 | `((define-record-type* . ,defrectype*-extractor)))) 55 | 56 | (define foreign-extractors 57 | (extend-extractors spells-extractors 58 | `((define . ,foreign:define-extractor)))) 59 | 60 | ) 61 | 62 | ;; Local Variables: 63 | ;; scheme-indent-styles: ((match 1)) 64 | ;; End: 65 | -------------------------------------------------------------------------------- /spells/procedure-annotations.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; procedure-annotations.sls --- Attach data to procedures. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Procedure annotations. 19 | (library (spells procedure-annotations) 20 | (export annotate-procedure 21 | procedure-annotation) 22 | (import (rnrs base) 23 | (spells define-values)) 24 | 25 | ;; Naive, portable implementation 26 | (define-values (annotate-procedure procedure-annotation) 27 | (let ((tag (list 'procedure-annotation))) 28 | (values 29 | (lambda (proc value) 30 | (lambda args 31 | (if (and (not (null? args)) 32 | (null? (cdr args)) 33 | (eq? (car args) tag)) 34 | value 35 | (apply proc args)))) 36 | (lambda (proc) 37 | (proc tag)))))) 38 | -------------------------------------------------------------------------------- /spells/process/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.ikarus.sls --- OS processes, Ikarus compat. 3 | 4 | ;; Copyright (C) 2009, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells process compat) 19 | (export process? 20 | process-id 21 | process-input 22 | process-output 23 | process-errors 24 | 25 | spawn-process 26 | wait-for-process 27 | 28 | run-shell-command 29 | 30 | get-process-id) 31 | (import (rnrs base) 32 | (rnrs arithmetic bitwise) 33 | (rnrs io ports) 34 | (prefix (only (ikarus) 35 | process* 36 | waitpid 37 | wstatus-exit-status 38 | wstatus-received-signal 39 | system) 40 | ik:) 41 | (srfi :8 receive) 42 | (srfi :9 records) 43 | (spells ports) 44 | (spells pathname)) 45 | 46 | (define-record-type process 47 | (make-process pid input output errors) 48 | process? 49 | (pid process-id) 50 | (input process-input) 51 | (output process-output) 52 | (errors process-errors)) 53 | 54 | (define (x->strlist lst) 55 | (map (lambda (s) 56 | (cond ((string? s) s) 57 | ((pathname? s) (->namestring s)) 58 | (else 59 | (error 'x->strlist 60 | "cannot coerce to string list" 61 | lst)))) 62 | lst)) 63 | 64 | (define (spawn-process env stdin stdout stderr prog . args) 65 | (receive (pid p-in p-out p-err) 66 | (apply ik:process* #f env stdin stdout stderr 67 | (x->strlist (cons prog args))) 68 | (make-process pid p-in p-out p-err))) 69 | 70 | (define (wstatus->values wstatus) 71 | (values (ik:wstatus-exit-status wstatus) 72 | (ik:wstatus-received-signal wstatus))) 73 | 74 | (define (wait-for-process process) 75 | (wstatus->values (ik:waitpid (process-id process)))) 76 | 77 | (define (get-process-id) 78 | ;; FIXME: Ikarus doesn't wrap getpid() yet. 79 | 123567890) 80 | 81 | (define (run-shell-command cmd) 82 | ;; This is a hack, but works (at least) on Linux. See 83 | ;; . 84 | (let* ((wstatus (ik:system cmd)) 85 | (sig (bitwise-and wstatus #xff))) 86 | (values (bitwise-arithmetic-shift-right wstatus 8) 87 | (if (= sig 0) #f sig))))) 88 | 89 | ;; Local Variables: 90 | ;; scheme-indent-styles: ((ik:register-callback 1)) 91 | ;; End: 92 | -------------------------------------------------------------------------------- /spells/process/compat.mosh.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; compat.mosh.sls - (spells process) compatibility layer for Mosh 3 | ; copyright: 2011 David Banks ; license: BSD-3-clause 4 | 5 | (library (spells process compat) 6 | (export process? 7 | process-id 8 | process-input 9 | process-output 10 | process-errors 11 | 12 | spawn-process 13 | wait-for-process 14 | 15 | get-process-id 16 | run-shell-command) 17 | (import (rnrs base) 18 | (rnrs control) 19 | (rnrs io ports) 20 | (only (srfi :1) first second) 21 | (srfi :9) 22 | (prefix (mosh process) mosh:) 23 | (spells pathname)) 24 | 25 | (define-record-type process 26 | (make-process pid input output errors) 27 | process? 28 | (pid process-id) 29 | (input process-input) 30 | (output process-output) 31 | (errors process-errors)) 32 | 33 | (define (->str who s) 34 | (cond 35 | ((string? s) s) 36 | ((pathname? s) (->namestring s)) 37 | (else 38 | (assertion-violation who "cannot coerce to string" s)))) 39 | 40 | ; Used by SPAWN-PROCESS. 41 | (define (maybe-create-pipe val) 42 | (if val 43 | #f 44 | (call-with-values mosh:pipe list))) 45 | 46 | (define pipe:in first) 47 | (define pipe:out second) 48 | 49 | ; The structure returned by spawn-process has the following members: 50 | ; * An output port representing stdin of the subprocess. 51 | ; * An input port represting stdout of the subprocess. 52 | ; * An input port representing stderr of the subprocess. 53 | (define (spawn-process env stdin stdout stderr prog . args) 54 | (let ((convert (lambda (x) (->str 'spawn-process x))) 55 | (in-ports (maybe-create-pipe stdin)) 56 | (out-ports (maybe-create-pipe stdout)) 57 | (err-ports (maybe-create-pipe stderr))) 58 | (let ((io-list (list (or stdin (pipe:in in-ports)) 59 | (or stdout (pipe:out out-ports)) 60 | (or stderr (pipe:out err-ports))))) 61 | (let-values (((pid in out err) (apply mosh:spawn 62 | (convert prog) 63 | (map convert args) 64 | io-list 65 | #f ; no PATH search 66 | (if env env '())))) 67 | (make-process pid 68 | (if stdin #f (pipe:out in-ports)) 69 | (if stdout #f (pipe:in out-ports)) 70 | (if stderr #f (pipe:in err-ports))))))) 71 | 72 | 73 | (define (wait-for-process process) 74 | (let-values (((child-pid status termsig) (mosh:waitpid (process-id process)))) 75 | (values status termsig))) 76 | 77 | (define (get-process-id) 78 | (mosh:getpid)) 79 | 80 | (define (run-shell-command cmd) 81 | (let-values (((stdout exit termsig) (mosh:call-process cmd))) 82 | (values exit termsig))) 83 | ) 84 | 85 | 86 | -------------------------------------------------------------------------------- /spells/process/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.mzscheme.sls --- OS process, mzscheme compat. 3 | 4 | ;; Copyright (C) 2009, 2010, 2012, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells process compat) 19 | (export process? 20 | process-id 21 | process-input 22 | process-output 23 | process-errors 24 | 25 | spawn-process 26 | wait-for-process 27 | 28 | get-process-id 29 | 30 | run-shell-command) 31 | (import (rnrs base) 32 | (rnrs io ports) 33 | (only (scheme base) 34 | subprocess subprocess-wait subprocess-status 35 | current-environment-variables 36 | make-environment-variables 37 | parameterize 38 | string->bytes/utf-8) 39 | (only (scheme system) 40 | system/exit-code) 41 | (only (mzlib os) getpid) 42 | (only (r6rs private ports) 43 | r6rs-port->port) 44 | (only (srfi :1) append-map) 45 | (srfi :8 receive) 46 | (srfi :9 records) 47 | (spells pathname)) 48 | 49 | (define-record-type process 50 | (make-process id input output errors) 51 | process? 52 | (id process-id) 53 | (input process-input) 54 | (output process-output) 55 | (errors process-errors)) 56 | 57 | (define (x->strlist lst) 58 | (map (lambda (s) 59 | (cond ((string? s) s) 60 | ((pathname? s) (->namestring s)) 61 | (else 62 | (error 'x->strlist "cannot coerce to string list" lst s)))) 63 | lst)) 64 | 65 | (define (maybe-port->mz-port port) 66 | (and port (r6rs-port->port port))) 67 | 68 | (define (env->environment-variables env) 69 | (if env 70 | (apply make-environment-variables 71 | (append-map (lambda (entry) 72 | (list (string->bytes/utf-8 (car entry)) 73 | (string->bytes/utf-8 (cdr entry)))) 74 | env)) 75 | (current-environment-variables))) 76 | 77 | (define (spawn-process env stdin stdout stderr prog . args) 78 | (receive (process stdout-port stdin-port stderr-port) 79 | (parameterize ((current-environment-variables 80 | (env->environment-variables env))) 81 | (apply subprocess 82 | (maybe-port->mz-port stdout) 83 | (maybe-port->mz-port stdin) 84 | (maybe-port->mz-port stderr) 85 | (x->strlist (cons prog args)))) 86 | (make-process process stdin-port stdout-port stderr-port))) 87 | 88 | (define (status->values status) 89 | (if (<= 0 status) 90 | (values status #f) 91 | (values status 'unknown))) 92 | 93 | (define (wait-for-process process) 94 | (subprocess-wait (process-id process)) 95 | (status->values (subprocess-status (process-id process)))) 96 | 97 | (define (run-shell-command cmd) 98 | (status->values (system/exit-code cmd))) 99 | 100 | (define (get-process-id) 101 | (getpid)) 102 | 103 | ) 104 | -------------------------------------------------------------------------------- /spells/process/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.ypsilon.sls --- process compat library for Ypsilon 3 | 4 | ;; Copyright (C) 2008, 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells process compat) 19 | (export process? 20 | process-id 21 | process-input 22 | process-output 23 | process-errors 24 | 25 | spawn-process 26 | wait-for-process 27 | 28 | get-process-id 29 | 30 | run-shell-command) 31 | (import (rnrs base) 32 | (rnrs io ports) 33 | (rnrs arithmetic bitwise) 34 | (srfi :8 receive) 35 | (srfi :9 records) 36 | (spells pathname) 37 | (prefix (only (core primitives) 38 | process-spawn 39 | process 40 | process-wait 41 | system) 42 | yp:) 43 | (only (core destructuring) destructuring-bind)) 44 | 45 | (define-record-type process 46 | (make-process pid input output errors) 47 | process? 48 | (pid process-id) 49 | (input process-input) 50 | (output process-output) 51 | (errors process-errors)) 52 | 53 | (define (x->strlist who lst) 54 | (map (lambda (s) 55 | (cond ((string? s) s) 56 | ((pathname? s) (->namestring s)) 57 | (else 58 | (error who "cannot coerce to string list" lst)))) 59 | lst)) 60 | 61 | (define (spawn-process env stdin stdout stderr prog . args) 62 | (destructuring-bind (pid p-in p-out p-err) 63 | (apply yp:process-spawn #f env stdin stdout stderr 64 | (x->strlist 'spawn-process (cons prog args))) 65 | (make-process pid p-in p-out p-err))) 66 | 67 | (define (status->values status) 68 | (if (>= status 0) 69 | (values status #f) 70 | (values #f (- status)))) 71 | 72 | (define (wait-for-process process) 73 | (status->values (yp:process-wait (process-id process) #f))) 74 | 75 | (define (run-shell-command cmd) 76 | (status->values (yp:system cmd))) 77 | 78 | (define (get-process-id) 79 | ;; FIXME: Ypsilon doesn't wrap getpid() yet. 80 | 12356789) 81 | 82 | ) 83 | -------------------------------------------------------------------------------- /spells/queue.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; queue.sls --- Simple, imperative queue. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Imperative queues. 19 | (library (spells queue) 20 | (export queue? 21 | make-empty-queue 22 | queue-empty? 23 | enqueue! 24 | dequeue!) 25 | 26 | (import (rnrs base) 27 | (rnrs control) 28 | (rnrs mutable-pairs) 29 | (rnrs records syntactic)) 30 | 31 | (define-record-type queue 32 | (fields (mutable front) 33 | (mutable back))) 34 | 35 | (define (make-empty-queue) 36 | (make-queue '() '())) 37 | 38 | ;;@ Return @code{#t} if the queue @1 is empty, @code{#f} otherwise. 39 | (define (queue-empty? q) 40 | (null? (queue-front q))) 41 | 42 | ;;@ Insert the element @2 into the queue @1. 43 | (define (enqueue! q x) 44 | (let ((pr (cons x '())) 45 | (back (queue-back q))) 46 | (unless (null? back) 47 | (set-cdr! back pr)) 48 | (queue-back-set! q pr) 49 | (when (null? (queue-front q)) 50 | (queue-front-set! q pr)))) 51 | 52 | ;;@ Dequeue an element from @1. 53 | (define (dequeue! q) 54 | (let ((front (queue-front q))) 55 | (when (null? front) 56 | (error 'dequeue! "queue is empty")) 57 | (queue-front-set! q (cdr front)) 58 | (when (null? (queue-front q)) 59 | (queue-back-set! q '())) 60 | (car front))) 61 | 62 | ) 63 | -------------------------------------------------------------------------------- /spells/record-types.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; record-types.sls --- Record types. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells record-types) 19 | (export define-record-type* 20 | define-functional-fields 21 | define-record-discloser) 22 | (import (rnrs) 23 | (for (spells record-types expand-drt) expand)) 24 | 25 | (define-syntax define-record-type* 26 | expand-define-record-type*) 27 | 28 | (define-syntax define-functional-fields 29 | expand-define-functional-fields) 30 | 31 | (define-syntax define-record-discloser 32 | (syntax-rules () 33 | ((define-record-discloser type proc) 34 | (begin)))) 35 | 36 | ) 37 | -------------------------------------------------------------------------------- /spells/syntax-utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; syntax-utils.sls --- Helpers for syntax-case 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells syntax-utils) 19 | (export identifier-append 20 | symbolic-identifier=?) 21 | (import (rnrs)) 22 | 23 | (define (identifier-append k . parts) 24 | (datum->syntax 25 | k 26 | (string->symbol (apply string-append 27 | (map (lambda (x) 28 | (cond ((string? x) x) 29 | ((identifier? x) 30 | (symbol->string (syntax->datum x))) 31 | (else (symbol->string x)))) 32 | parts))))) 33 | 34 | (define (symbolic-identifier=? x y) 35 | (eq? (if (identifier? x) (syntax->datum x) x) 36 | (if (identifier? y) (syntax->datum y) y))) 37 | 38 | ) 39 | -------------------------------------------------------------------------------- /spells/sysutils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;;@ Miscellaneous procedures providing access to various bits of 4 | ;; information regarding the host running the scheme implementation. 5 | (library (spells sysutils) 6 | (export lookup-environment-variable 7 | current-process-environment 8 | extend-process-environment 9 | find-exec-path 10 | host-info) 11 | (import (rnrs base) 12 | (rnrs lists) 13 | (srfi :98 os-environment-variables) 14 | (spells sysutils compat)) 15 | 16 | (define lookup-environment-variable get-environment-variable) 17 | (define current-process-environment get-environment-variables) 18 | 19 | (define (extend-process-environment env) 20 | (let ((current-env (remp (lambda (x) (assoc (car x) env)) 21 | (current-process-environment)))) 22 | (append env current-env))) 23 | 24 | ) 25 | -------------------------------------------------------------------------------- /spells/sysutils/compat.guile.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; compat.guile.sls --- Guile sysutils compatibility 3 | 4 | ;; Copyright (C) 2010, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells sysutils compat) 19 | (export find-exec-path 20 | host-info) 21 | (import (rnrs base) 22 | (spells filesys) 23 | (only (guile) 24 | uname 25 | utsname:machine 26 | utsname:sysname 27 | getenv 28 | string-split)) 29 | 30 | (define (find-exec-path prog) 31 | (let ((paths (string-split (getenv "PATH") #\:))) 32 | (find-file prog paths file-executable?))) 33 | 34 | (define (host-info) 35 | (let ((uts (uname))) 36 | (values (utsname:machine uts) 37 | "unknown" 38 | (utsname:sysname uts)))) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /spells/sysutils/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;;@ Miscellaneous procedures providing access to various bits of 2 | ;; information regarding the host running the scheme implementation. 3 | (library (spells sysutils compat) 4 | (export find-exec-path 5 | host-info) 6 | (import (rnrs base) 7 | (srfi :8 receive) 8 | (spells filesys) 9 | (spells string-utils) 10 | (only (srfi :13 strings) string-index) 11 | (prefix (only (ikarus) 12 | getenv 13 | host-info) 14 | ik:)) 15 | 16 | (define (find-exec-path prog) 17 | (let ((paths (string-split (ik:getenv "PATH") #\:))) 18 | (find-file prog paths file-executable?))) 19 | 20 | (define (host-info) 21 | (let* ((hi (ik:host-info)) 22 | (first-dash (string-index hi #\-)) 23 | (second-dash (and first-dash (string-index hi #\- (+ first-dash 1))))) 24 | (cond ((and first-dash second-dash) 25 | (values (substring hi 0 first-dash) 26 | (substring hi (+ first-dash 1) second-dash) 27 | (substring hi (+ second-dash 1) (string-length hi)))) 28 | (first-dash 29 | (values (substring hi 0 first-dash) 30 | "unknown" 31 | (substring hi (+ first-dash 1) (string-length hi)))) 32 | (else 33 | (values "unknown" "unknown" hi))))) 34 | 35 | ) 36 | -------------------------------------------------------------------------------- /spells/sysutils/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (C) 2008, 2009, 2010, 2015 Andreas Rottmann 3 | ;; Copyright (C) 2005, 2007 Jose Antonio Ortega Ruiz 4 | 5 | ;; Authors: Andreas Rottmann 6 | ;; Jose Antonio Ortega Ruiz 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells sysutils compat) 19 | (export find-exec-path 20 | host-info) 21 | 22 | (import (rnrs) 23 | (srfi :98 os-environment-variables) 24 | (spells pathname) 25 | (only (scheme base) 26 | system-type 27 | path->string 28 | find-executable-path)) 29 | 30 | (define (find-exec-path prog) 31 | (let ((path (find-executable-path (->namestring prog) #f))) 32 | (and path (->pathname (path->string path))))) 33 | 34 | (define (host-info) 35 | (values "unknown" "unknown "(symbol->string (system-type 'os))))) 36 | -------------------------------------------------------------------------------- /spells/sysutils/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; sysutils.ypsilon.sls --- Ypsilon sysutils 3 | 4 | ;; Copyright (C) 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells sysutils compat) 19 | (export find-exec-path 20 | host-info) 21 | (import (rnrs base) 22 | (rnrs records syntactic) 23 | (srfi :8 receive) 24 | (spells string-utils) 25 | (spells filesys) 26 | (only (core) 27 | architecture-feature 28 | getenv 29 | process-environment->alist) 30 | (only (ypsilon ffi) on-posix)) 31 | 32 | (define (find-exec-path prog) 33 | (let ((paths (string-split (getenv "PATH") #\:))) 34 | (find-file prog paths file-executable?))) 35 | 36 | (define (host-info) 37 | (let ((os (architecture-feature 'operating-system))) 38 | (values 39 | (architecture-feature 'machine-hardware) 40 | "unknown" 41 | (cond ((string=? os "linux") "linux-gnu") 42 | (else os))))) 43 | 44 | ) 45 | -------------------------------------------------------------------------------- /spells/table.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; table.sls --- Simple hash tables. 3 | 4 | ;; Copyright (C) 2009, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Simple hash tables. 19 | (library (spells table) 20 | (export make-table 21 | table? 22 | table-ref 23 | table-set! 24 | table-walk 25 | table-fold 26 | table->alist) 27 | (import (rnrs base) 28 | (spells table compat)) 29 | 30 | ;;@ Return an association list that corresponds to @1. 31 | (define (table->alist table) 32 | (let ((alist '())) 33 | (table-walk table 34 | (lambda (key value) 35 | (set! alist (cons (cons key value) alist)))) 36 | alist)) 37 | 38 | (define (table-fold proc init table) 39 | (let ((result init)) 40 | (table-walk table 41 | (lambda (key value) 42 | (set! result (proc key value result)))) 43 | result)) 44 | 45 | (define (default-failure-thunk) #f)) 46 | 47 | ;; arch-tag: ebb30766-d8c9-4468-8cb5-a3ceb5c4a592 48 | -------------------------------------------------------------------------------- /spells/table/compat.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; table.scm -- Hash tables 3 | 4 | ;; Copyright (C) 2005, 2008, 2009, 2011, 2015 by Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells table compat) 19 | (export make-table table? table-ref table-set! table-walk) 20 | (import (rnrs base) 21 | (rnrs control) 22 | (rnrs hashtables)) 23 | 24 | ;;@ Create a hash table. The optional argument @var{type} can be 25 | ;; either @code{'eq}, @code{'eqv} or @code{'equal}. 26 | (define make-table 27 | (case-lambda 28 | (() 29 | (make-hashtable)) 30 | ((type) 31 | (case type 32 | ((eq) (make-eq-hashtable)) 33 | ((eqv) (make-eqv-hashtable)) 34 | ((equal) (make-hashtable equal-hash equal?)) 35 | (else (error 'make-table "invalid hash table type")))))) 36 | 37 | ;;@ Table type predicate. Hash tables are a disjoint type. 38 | (define table? hashtable?) 39 | 40 | ;;@args table key [ failure-thunk ] 41 | ;; Lookup @2 in @1. If no value is found for key @2, return the value 42 | ;; obtained by invoking @3 with no arguments, or #f if the optional 43 | ;; argument @3 is not specified. 44 | (define table-ref 45 | (let ((fail (list 'fail))) 46 | (case-lambda 47 | ((table key) 48 | (hashtable-ref table key #f)) 49 | ((table key failure-thunk) 50 | (let ((result (hashtable-ref table key fail))) 51 | (if (eq? result fail) 52 | (failure-thunk) 53 | result)))))) 54 | 55 | ;;@ Set the value correspoinding to @2 in @1 to @3. 56 | (define (table-set! table key value) 57 | (if value 58 | (hashtable-set! table key value) 59 | (hashtable-delete! table key))) 60 | 61 | ;;@ Call @2 with the key and value of every entry in @1 as arguments. 62 | (define (table-walk table proc) 63 | (let ((keys (hashtable-keys table))) 64 | (do ((i 0 (+ i 1))) 65 | ((< i (vector-length keys))) 66 | (let ((key (vector-ref keys))) 67 | (proc key (hashtable-ref table key #f)))))) 68 | 69 | ) 70 | 71 | -------------------------------------------------------------------------------- /spells/test-runner/env.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (C) 2015 Andreas Rottmann 3 | 4 | ;; This program is free software, you can redistribute it and/or 5 | ;; modify it under the terms of the new-style BSD license. 6 | 7 | ;; You should have received a copy of the BSD license along with this 8 | ;; program. If not, see . 9 | 10 | (library (spells test-runner env) 11 | (export this-directory 12 | test-environment) 13 | (import (rnrs) 14 | (srfi :39 parameters) 15 | (spells pathname)) 16 | 17 | (define this-directory 18 | (make-parameter (->namestring 19 | (pathname-with-file (->pathname (car (command-line))) #f)))) 20 | 21 | (define test-environment (make-parameter #f))) 22 | -------------------------------------------------------------------------------- /spells/testing-utils.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; testing-utils.sls --- Utilities for use with trc-testing 3 | 4 | ;; Copyright (C) 2010, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells testing-utils) 19 | (export test-one-of) 20 | (import (rnrs) 21 | (wak trc-testing)) 22 | 23 | (define-syntax test-one-of 24 | (syntax-rules () 25 | ((test-one-of comparator-expression expected-expression actual-expression) 26 | (let ((comparator comparator-expression)) 27 | (test-compare (lambda (expected-datums actual-datum) 28 | (exists (lambda (e) 29 | (comparator e actual-datum)) 30 | expected-datums)) 31 | expected-expression 32 | actual-expression))))) 33 | 34 | ) 35 | -------------------------------------------------------------------------------- /spells/time-it.ikarus.sls: -------------------------------------------------------------------------------- 1 | (library (spells time-it) 2 | (export (rename (time time-it))) 3 | (import (ikarus))) 4 | -------------------------------------------------------------------------------- /spells/time-lib.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; time-lib.sls --- Time library. 3 | 4 | ;; Copyright (C) 2009, 2010, 2011, 2015 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | (library (spells time-lib) 19 | (export posix-timestamp->time-utc 20 | time-utc->posix-timestamp 21 | time-utc->posix-offset 22 | date-up-from 23 | date-down-from) 24 | (import 25 | (rnrs base) 26 | (srfi :19 time) 27 | (spells opt-args)) 28 | 29 | (define *posix-epoch* (date->time-utc (make-date 0 0 0 0 1 1 1970 0))) 30 | 31 | (define* (posix-timestamp->time-utc timestamp (nanoseconds 0)) 32 | (add-duration *posix-epoch* (make-time time-duration nanoseconds timestamp))) 33 | 34 | (define (time-utc->posix-timestamp time-utc) 35 | (time-second (time-utc->posix-offset time-utc))) 36 | 37 | (define (time-utc->posix-offset time-utc) 38 | (time-difference time-utc *posix-epoch*)) 39 | 40 | (define one-day (make-time time-duration 0 (* 24 60 60))) 41 | 42 | (define-syntax date-up-from 43 | (syntax-rules () 44 | ((_ (date-var) (start-expr (to end-expr)) cont . env) 45 | (cont 46 | (((end) (date->time-utc end-expr)) ;Outer bindings 47 | ((start tz) (let ((start start-expr)) 48 | (values start (date-zone-offset start)))) 49 | ((step) one-day)) 50 | ((time-var (date->time-utc start) ;Loop variables 51 | (add-duration time-var step))) 52 | () ;Entry bindings 53 | ((time>=? time-var end)) ;Termination conditions 54 | (((date-var) ;Body bindings 55 | (time-utc->date time-var tz))) 56 | () ;Final bindings 57 | . env)))) 58 | 59 | (define-syntax date-down-from 60 | (syntax-rules () 61 | ((_ (date-var) (start-expr (to end-expr)) cont . env) 62 | (cont 63 | (((end) (date->time-utc end-expr)) ;Outer bindings 64 | ((start tz) (let ((start start-expr)) 65 | (values start (date-zone-offset start)))) 66 | ((step) one-day)) 67 | ((time-var (date->time-utc start) ;Loop variables 68 | (subtract-duration time-var step))) 69 | () ;Entry bindings 70 | ((time<=? time-var end)) ;Termination conditions 71 | (((date-var) ;Body bindings 72 | (time-utc->date time-var tz))) 73 | () ;Final bindings 74 | . env)))) 75 | 76 | ) 77 | -------------------------------------------------------------------------------- /spells/tracing.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; tracing.sls --- Trace procedure invocations. 3 | 4 | ;; Copyright (C) 2009, 2011 Andreas Rottmann 5 | 6 | ;; Author: Andreas Rottmann 7 | 8 | ;; This program is free software, you can redistribute it and/or 9 | ;; modify it under the terms of the new-style BSD license. 10 | 11 | ;; You should have received a copy of the BSD license along with this 12 | ;; program. If not, see . 13 | 14 | ;;; Commentary: 15 | 16 | ;;; Code: 17 | 18 | ;;@ Trace procedures for debugging. 19 | (library (spells tracing) 20 | (export trace-define trace-lambda trace-procedure) 21 | (import (rnrs base) 22 | (spells tracing compat)) 23 | 24 | ;;@defspec trace-lambda 25 | ;; @lisp 26 | ;; (trace-lambda @var{label} @var{arguments} 27 | ;; @var{body} @dots{})@end lisp 28 | ;;@end defspec 29 | 30 | ;;@defspec trace-define 31 | ;; @lisp 32 | ;; (trace-define (@var{name} . @var{arguments}) 33 | ;; @var{body} @dots{})@end lisp 34 | ;;@end defspec 35 | 36 | 37 | ;;@defspec trace-procedure 38 | ;; @lisp 39 | ;; (trace-procedure @var{label} @var{procedure})@end lisp 40 | ;; 41 | ;; Returns a wrapper procedure that traces calls to @var{procedure}, 42 | ;; which must be an expression that evaluates to a procedure. As with 43 | ;; @code{trace-lambda}, @var{label} is an identifier for use in the 44 | ;; trace output. 45 | ;; 46 | ;;@end defspec 47 | 48 | (define-syntax trace-procedure 49 | (syntax-rules () 50 | ((trace-procedure