├── .gitattributes ├── .gitignore ├── .gitlab-ci.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── INSTALL.md ├── LICENSE.txt ├── README.md ├── SRFI.md ├── airship-scheme.asd ├── cl-macros.lisp ├── equality.lisp ├── examples ├── README.md ├── base.sld ├── hello-world.scm └── syntax.scm ├── extra-procedures.lisp ├── package.lisp ├── scheme-boolean.lisp ├── scheme-core.lisp ├── scheme-read.lisp ├── scheme-string.lisp ├── scheme-types.lisp ├── scheme-write.lisp ├── scheme ├── base.sld ├── case-lambda.sld ├── char.sld ├── complex.sld ├── cxr.sld ├── eval.sld ├── file.sld ├── inexact.sld ├── lazy.sld ├── load.sld ├── process-context.sld ├── r5rs.sld ├── read.sld ├── repl.sld ├── time.sld └── write.sld ├── srfi ├── 172 │ └── functional.sld ├── 112.sld ├── 172.sld ├── 6.sld ├── 87.sld ├── 9.sld └── 98.sld ├── standard-procedures.lisp ├── tests ├── package.lisp ├── test-script.lisp └── tests.lisp └── util.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | *.lisp linguist-language=Common-Lisp 2 | *.scm linguist-language=Scheme 3 | *.sld linguist-language=Scheme 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | .* 3 | \#* 4 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: debian:latest 2 | 3 | stages: 4 | - test 5 | 6 | before_script: 7 | - apt-get update -qq > /dev/null 8 | - apt-get install -qq git-core sbcl cl-quicklisp > /dev/null 9 | - sbcl --noinform --non-interactive --eval '(load "/usr/share/common-lisp/source/quicklisp/quicklisp.lisp")' --eval '(quicklisp-quickstart:install)' --eval '(ql-util:without-prompting (ql:add-to-init-file))' 10 | - git clone https://gitlab.com/zombie-raptor/zr-utils ~/quicklisp/local-projects/zr-utils 11 | - ln -s "${CI_PROJECT_DIR}" ~/quicklisp/local-projects/airship-scheme 12 | 13 | test: 14 | stage: test 15 | script: 16 | - sbcl --non-interactive --load ~/quicklisp/local-projects/airship-scheme/tests/test-script.lisp 17 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | This changelog uses the style from [Keep a 4 | Changelog](https://keepachangelog.com/en/1.0.0/). 5 | 6 | ## [Unreleased] 7 | 8 | ### Added 9 | - Common Lisp implementations of the Scheme character and string 10 | functionality, including a wrapper over `sb-unicode`, the Unicode 11 | functionality of SBCL, when present. 12 | - Common Lisp implementations of the main Scheme equality predicates. 13 | - A separate false value from `nil`, which is not false in Scheme. 14 | - A `define-scheme-type` macro family, which partially `Lisp-1`ifies 15 | the separate type namespace by creating a predicate for each type 16 | that is defined, using the predicate's name as the type name, e.g. 17 | `number?`. 18 | - Some efficient, custom types that match CL's type system, 19 | including `%list?` for lists that aren't necessarily proper 20 | lists. 21 | - A custom reader for the [R7RS-small] version of Scheme. 22 | - A CL-style syntax extension for specifying short, single, double, 23 | and long floats, which is permitted by the R7RS standard. 24 | - A few other minor syntax extensions, particularly around numbers, 25 | to permit some commonly allowed syntax that is technically not 26 | fully portable. For instance, both `2i` and `+2i` are read as 27 | `0+2i`, but `2i` is technically an extension to the syntax. 28 | - Many potential numbers become symbols, especially starting with 29 | `+` and `-`. This is necessary to interoperate with CL `+foo+` 30 | style constants. 31 | - A custom writer that displays s-expressions in Scheme syntax 32 | instead of Common Lisp syntax. 33 | - An internal representation for Scheme that supports tail recursion 34 | and continuations. 35 | - Macros for writing parts of this Scheme from Common Lisp, as 36 | `define-scheme-procedure` (`nil` is the empty list) and 37 | `define-scheme-predicate` (`nil` is turned into `#f`). 38 | - A hello world example file and an example library that exports that 39 | hello world. 40 | - A substantial number of standard procedures from [R7RS-small]: 41 | - Almost all of sections 6.1 through 6.9, only excluding 42 | `rationalize`. 43 | - Section 6.13, i.e. ports (streams in CL). 44 | - Some Scheme libraries: 45 | - Library definitions for the `(scheme)` libraries described in 46 | [R7RS-small] Appendix A. 47 | - Some SRFIs entirely contained within R7RS-small: 6, 9, 87, and 98. 48 | - [SRFI 112] and [SRFI 172]. 49 | 50 | [R7RS-small]: https://small.r7rs.org/attachment/r7rs.pdf 51 | [SRFI 112]: https://srfi.schemers.org/srfi-112/srfi-112.html 52 | [SRFI 172]: https://srfi.schemers.org/srfi-172/srfi-172.html 53 | [Unreleased]: https://gitlab.com/mbabich/airship-scheme/-/compare/bd61fb8f...master 54 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing to Airship Scheme 2 | ============================== 3 | 4 | For the Common Lisp code, Airship Scheme uses the same guidelines as 5 | the Zombie Raptor game engine, where the guidelines still make sense. 6 | Things specific to the game engine do not apply. Eventually, the 7 | things in common will be spun off into a separate guide, containing 8 | only the information that all Common Lisp projects share in common. 9 | For more, see [its contributing 10 | guide](https://gitlab.com/zombie-raptor/zombie-raptor/-/blob/master/CONTRIBUTING.md). 11 | 12 | The special nature of being a project at the intersection of Common 13 | Lisp and Scheme requires some special attention because of the 14 | similarities and differences between the two languages, which are 15 | closely related, but with divergences in key places. 16 | 17 | The Scheme code will generally be written in a similar style to a 18 | Common Lisp project, but fundamental differences exist between the two 19 | languages making style concerns not entirely trivial. A separate 20 | Airship Scheme style guide will have to be written in the future. 21 | 22 | Complications and design solutions 23 | ---------------------------------- 24 | 25 | ### Symbol case 26 | 27 | Common Lisp is, in its default behavior, effectively case-insensitive 28 | for its symbols. It does this by upcasing any lower case input. For 29 | example, `car` becomes `CAR`. This was done for maximal backwards 30 | compatibility. These days, Common Lisp is mostly written in lower case 31 | and relies on this automatic conversion to upper case. Scheme, on the 32 | other hand, is a case-sensitive programming language. Thus, `car` in 33 | Scheme remains `car` and a Scheme program could define a separate 34 | `Car` or `CAR` that needs to be treated separately. The easiest 35 | solution to this problem is to *invert* the case of the Scheme 36 | implementation. In other words, `car` becomes `CAR` internally and 37 | `Car` would become `cAR` internally. 38 | 39 | ### `NIL` vs. `#f` 40 | 41 | Common Lisp does not distinguish between false and the empty list, 42 | treating both as `NIL`. Scheme, on the other hand, distinguishes 43 | between the false value `#f` and the empty list `'()`. In order to 44 | preserve the native cons cell data structure, Airship Scheme chooses 45 | to have a separate false value for Scheme. 46 | 47 | This means that any wrapped Common Lisp function must have its 48 | semantics distinguished as either a regular procedure or a predicate. 49 | This is done by providing both the `define-scheme-procedure` and 50 | `define-scheme-predicate` macros. In a Scheme procedure, CL's `NIL` is 51 | treated as the empty list and not converted. In a Scheme predicate, 52 | the CL call is wrapped by a simple function that converts `NIL` to 53 | Scheme's `#f`. The other direction is easier. Calling Scheme from CL 54 | will always turn `#f` into `NIL`, although that means that some 55 | information may be lost. 56 | 57 | Internally, Scheme's `#f` is just `'%scheme-boolean:f`. There should 58 | be no performance penalty because most Common Lisp implementations are 59 | already comparing to `NIL` to find false. All that changes is the 60 | exact symbol that's being used. 61 | 62 | ### Tail recursion 63 | 64 | Common Lisp does not guarantee optimized tail recursion, even though 65 | some implementations do offer it. Even when that is the case, tail 66 | recursion semantics cannot be treated as necessarily identical to 67 | Scheme's. Additionally, differing optimization levels can take code 68 | that would normally have tail recursion and remove the tail recursion. 69 | This is unacceptable from the perspective of a guest Scheme in the CL 70 | environment because tail recursion is the idiomatic iteration in 71 | Scheme and unexpected recursion limits would be bad. 72 | 73 | For this reason, there needs to be a minimal runtime environment, 74 | where the guest Scheme code does recursion through a 75 | [trampoline](https://en.wikipedia.org/wiki/Trampoline_(computing)). 76 | This guarantees tail recursion and in testing has shown to have no 77 | noticeable performance loss over a CL implementation's native tail 78 | recursion. 79 | 80 | ### Environments 81 | 82 | Although Common Lisp has lexical scope in addition to dynamic scope, 83 | the standard Common Lisp global variable environment, via `defvar` or 84 | `defparameter` is always dynamically scoped. This means that while 85 | Common Lisp environments can normally be used, they cannot be used for 86 | a mutable global Scheme environment for things like the REPL and CL's 87 | interactive, SLIME-style development. This has not yet been completely 88 | addressed. 89 | 90 | Additionally, CL is a Lisp-2 (having separate variable and function 91 | namespaces) while Scheme is a Lisp-1 (having a combined 92 | variable-and-function namespace), meaning that the Scheme code should 93 | be able to create a second, function-namespace binding that the CL can 94 | call into. This would be desirable, anyway, because CL calling into 95 | Scheme needs to add a trampoline at the entry point. [Wikipedia 96 | explains dynamic scope in 97 | detail.](https://en.wikipedia.org/wiki/Scope_(computer_science)#Dynamic_scoping) 98 | 99 | ### Type system 100 | 101 | Portable Scheme only has the predicates, such as `list?`. Scheme can 102 | be thought of as being "predicatively" typed. Airship Scheme uses this 103 | convention in its type names, making its Scheme type names end in `?`. 104 | 105 | Technically, Common Lisp isn't just a "Lisp-2". It actually has more 106 | than two namespaces. The third most popular namespace is the *type* 107 | namespace, used by types defined by `defclass`, `deftype`, etc. One 108 | possible solution is to introduce this type namespace to Scheme, but 109 | standard Scheme is predicately typed. These could be seen as 110 | `satisfies` types in CL, but those are inefficient. The simplest 111 | efficient solution, then, is to have a `define-scheme-type` macro that 112 | defines both a type and a predicate of the same name (e.g. `pair?`). 113 | 114 | Thus, in Airship Scheme, properly defined Scheme types always define a 115 | corresponding predicate of the same name, but are probably defined in 116 | a more efficient way (such as `define-scheme-type` on the CL side or 117 | `define-type` on the Scheme side). 118 | 119 | This is generally done by automatically generating a trivially inline 120 | procedure that calls `typep` (in the CL side) or `type?` (in the 121 | Airship Scheme side). This means that this abstraction is a 122 | potentially leaky abstraction since the procedure might be redefined 123 | locally. However, `type?` will usually behave as expected because 124 | there is no local way to define a type. 125 | 126 | That is, technically speaking, this type namespace still exists and is 127 | accessed through an exposed `type?` predicate on the Scheme side. For 128 | example, `(type? foo 'pair?)` would be `#t` if `foo` is a `pair?` even 129 | if `pair?` has been locally rebound in a `let`. 130 | 131 | ### Continuations 132 | 133 | Common Lisp does not have Scheme-style continuations. This means that 134 | even if Common Lisp `lambda`s are used in the compilation process, the 135 | `lambda`s probably need to use something like Continuation Passing 136 | Style in order to allow for things like `call/cc` to work. 137 | 138 | Terminology differences 139 | ----------------------- 140 | 141 | Even though Scheme and Common Lisp are both Lisps, there are quite a 142 | few terminology differences between the two languages, making 143 | describing the details of project like this more complicated than it 144 | has to be. 145 | 146 | In Scheme, "procedures" are the named or unnamed `lambda`s. In Common 147 | Lisp, these are "functions". Scheme calls them "procedures" because 148 | its "functions" are what Common Lisp would call "pure functions": 149 | procedures without side effects. 150 | 151 | There are quite a few names for [the cons data 152 | structure](https://en.wikipedia.org/wiki/Cons). These include "cell", 153 | "cons", "cons cell", "cons pair", "pair", etc. Scheme tends to prefer 154 | "pair" instead of "cons", but that is a Scheme-ism. They are rarely, 155 | if ever, called "pairs" in Common Lisp, where "cons" or "cons cell" 156 | are more common. 157 | 158 | When a linked list is built from conses, there are two possibilities. 159 | Either the last `cdr` is `NIL` (or the empty list) or the last `cdr` 160 | is not. In the latter case, it is represented syntactically as a 161 | dotted list, like `(1 2 3 . 4)`, and is called an "improper list". 162 | Otherwise, it is represented without any dots like `(1 2 3 4)` and is 163 | called a "proper list". In Scheme, the word "list" without 164 | qualifications implies that it is a "proper list". In Common Lisp, 165 | this is not the case. This means, for example, that Scheme's `list?` 166 | tests for proper lists, while Common Lisp's `listp` tests for proper 167 | or improper lists. The Alexandria utility library offers an 168 | `alexandria:proper-list-p` that is equivalent to Scheme's `list?` 169 | procedure. 170 | 171 | Differing conventions 172 | --------------------- 173 | 174 | In general, Common Lisp has more consistent conventions than Scheme, 175 | with a few notable exceptions, such as Scheme's `!` naming convention 176 | for procedures with side effects. Where a clear convention exists in 177 | Scheme, Airship Scheme will follow that Scheme convention. Otherwise, 178 | Airship Scheme will borrow the convention from Common Lisp to ease 179 | interoperability, even if this convention hasn't been seen in Scheme 180 | before. 181 | 182 | ### Comments 183 | 184 | In Common Lisp, end-of-line comments start with `;`. Comments on their 185 | own line start with `;;` if not at the top level (i.e. if indented) 186 | and with `;;;` or `;;;;` if at the top level (i.e. if not indented). 187 | Generally, `;;;;` is used for file headers and `;;;` elsewhere, but 188 | not every project uses `;;;;`. Scheme mostly shares the same styles 189 | for s-expressions and comments as Common Lisp, but Schemers don't 190 | always insist on using `;;;`. In Scheme, `;;;;` is also infrequently 191 | seen. 192 | 193 | Airship Scheme **must** use the `;;;;` comment convention in both the 194 | Common Lisp and Scheme files. This means that comments on their own 195 | line that are not indented use `;;;` except if they are a heading 196 | and/or header (typically at the top of the file). Those use `;;;;` 197 | instead. 198 | 199 | #### Example 200 | 201 | The following example code has *terrible* style because the comments 202 | are unnecessary for the level of complexity, but the code demonstrates 203 | the three different levels of `;`s: 204 | 205 | ```common-lisp 206 | ;;; Squares the input 207 | (defun square (x) ; x is a number 208 | ;; Squares x 209 | (expt x 2)) 210 | ``` 211 | 212 | ```scheme 213 | ;;; Squares the input 214 | (define (square x) ; x is a number 215 | ;; Squares x 216 | (expt x 2)) 217 | ``` 218 | 219 | ### Naming conventions 220 | 221 | In Common Lisp, a slight variation of `foo` is usually called `foo*`. 222 | Something that's for low-level or internal-use is often called `%foo`. 223 | Airship Scheme uses this same convention. 224 | 225 | Scheme uses `foo->bar` for conversion procedures while Common Lisp 226 | tends to use `foo-to-bar`. 227 | 228 | #### Predicates 229 | 230 | In Common Lisp, predicates end with `p`. The old convention is to end 231 | with `p` if it is one word, such as `foop`, and end with `-p` if it is 232 | more than one word, such as `foo-bar-p`. A newer convention is to 233 | always end in `-p` so that it is always easy to tell if something is a 234 | predicate. Scheme always ends its predicates with `?`, such as `foo?`. 235 | Some Common Lisp code does this, but it is rare. This project will 236 | mostly use the Scheme convention, but there are times where it makes 237 | sense to make something look like it is a Common Lisp built-in, in 238 | particular when writing Common Lisp functions for 239 | `standard-procedures.lisp` to wrap. 240 | 241 | #### Side effects 242 | 243 | Most Scheme procedures with side effects end in `!`, e.g. `foo!`, 244 | making it easy to tell when something is pure or not. In Common Lisp, 245 | there is no direct equivalent, but `nfoo` (where `n` stands for 246 | "nonconsing") and `foof` (in the style of `setf` or `incf`) are often 247 | used. Both are problematic because a function with side effects *can* 248 | still be "consing" (i.e. heap-allocating) and `foof` is specifically 249 | for dealing with "places". For that reason, Common Lisp code that must 250 | distinguish side effects in a clear way should use `!`, but that's not 251 | as necessary in Common Lisp as in Scheme. In this project, `!` should 252 | be used. 253 | 254 | Some built-in Scheme procedures with side effects do not end in `!`, 255 | such as `display`. This is for historical reasons. New Scheme 256 | procedures with side effects should end in `!`, but I/O procedures in 257 | the style of `display` might still seem more idiomatic to exclude it. 258 | 259 | #### Global constants and variables 260 | 261 | Common Lisp constants are surrounded in `+`s, like `+foo+`. Scheme 262 | does not have a consistent convention for constants, but some Scheme 263 | readers might not recognize tokens beginning with `+` that aren't the 264 | symbol `+` itself (used for addition) as a symbol because `+` is also 265 | a numeric prefix (e.g. `+42` is a number). Airship Scheme does not 266 | have this limitation, and so will use the Common Lisp `+foo+` naming 267 | convention for its constants. 268 | 269 | Common Lisp global variables use "earmuffs", like `*foo*`. However, 270 | this is actually just a side effect of all portable Common Lisp global 271 | variables being dynamic (special) variables. Portable Scheme does not 272 | have dynamically scoped variables. 273 | 274 | #### Definitions 275 | 276 | In Common Lisp, `deffoo` is usually used for single word defines 277 | instead of `define-foo`, while `define-foo-bar` is always used for 278 | hyphenated names. This is not always the case. The Common Lisp 279 | standard itself uses the name `define-condition`. Scheme should always 280 | use `define-foo`. 281 | 282 | This traditional CL convention for `define`s is even more problematic 283 | for tools than the `p` predicate convention, so this project **must** 284 | always use the `define-` prefix in the Common Lisp portion of the 285 | code, even for the case of `define-foo`. Tools probably want to do 286 | interesting things with `define`s so machine-readability is more 287 | important than with predicates. (An Airship Scheme wrapper of Common 288 | Lisp code really could use a tool that automatically distinguishes 289 | between predicates and non-predicates due to how the wrapping process 290 | works, but Airship Scheme is a rare, special case in its needs.) 291 | 292 | #### Type names 293 | 294 | Common Lisp types are generally written like everything else, in lower 295 | case, and often have name collisions (e.g. `list` the type and `list` 296 | the function that creates a list) that aren't an issue because the 297 | type namespace is a separate namespace (similar to how variables and 298 | functions have different namespaces). Scheme types are inconsistent, 299 | but many implementations capitalize the start of a type name, e.g. 300 | `List`. 301 | 302 | As mentioned earlier, Airship Scheme uses the predicate convention in 303 | its type names, so all of its Scheme types should end in `?`. This is 304 | enforced through `define-scheme-type` on the CL side or `define-type` 305 | on the Scheme side. 306 | 307 | There are some built-in ways to define types in ways that might 308 | violate this, but it is still maintained by convention to have the 309 | type and the predicate to test for the type have the same name. In 310 | Airship Scheme it is conventional to use the same name for the `name` 311 | and the `predicate` parts of `define-record-type`, although they can 312 | be different. 313 | 314 | Scheme rarely provides efficient versions of various types, preferring 315 | the plainer definition, even if it requires a runtime predicate test. 316 | `exact-integer?` instead of `integer?` is a good example of where 317 | Scheme provides an efficient way, since `exact-integer?` will test for 318 | the underlying integer type (e.g. `42`) while `integer?` will test for 319 | the mathematical concept (including `42.0`). 320 | 321 | When efficient versions don't exist, Airship Scheme will have to 322 | define them, such as `%list?`, which permits improper lists and should 323 | be preferred when working with lists. 324 | 325 | *Cliki (the Common Lisp wiki) mentions the [Common Lisp naming 326 | conventions](https://www.cliki.net/Naming+conventions) in general and 327 | covers a lot of the same ground, with an emphasis on Common Lisp 328 | rather than an emphasis on contrasting CL with Scheme.* 329 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | Installation 2 | ============ 3 | 4 | Step 1: Install Common Lisp 5 | --------------------------- 6 | 7 | The Airship Scheme installation process depends on the user having an 8 | Common Lisp already installed. On Linux, your Linux distribution 9 | probably has an old version of SBCL available, which can then be used 10 | to compile a newer version of SBCL. On other OSes, you should be able 11 | to directly install a binary online, such as [here for 12 | SBCL](http://www.sbcl.org/platform-table.html), which will, again, 13 | probably be an outdated starting point for compiling the latest 14 | version. The latest version shouldn't be required, but this hasn't 15 | been tested on every old version of SBCL. 16 | 17 | There are also tools that exist to make this process more 18 | beginner-friendly. The most popular is probably 19 | **[Portacle](https://portacle.github.io/)**. Additionally, 20 | [Roswell](https://github.com/roswell/roswell) is another option. 21 | 22 | **SBCL is recommended.** CCL should also work. The more obscure the CL 23 | implementation, the less likely it is for all of the features to be 24 | available because Airship Scheme depends on third-party or 25 | implementation-provided libraries in certain places and not every 26 | implementation exposes all of the necessary functionality. 27 | 28 | **Note: While the basic R7RS language is still incomplete, only SBCL 29 | will be used for testing and development to keep things simple.** 30 | 31 | Step 2: Install Quicklisp 32 | ------------------------- 33 | 34 | In Common Lisp, **[Quicklisp](https://www.quicklisp.org/beta/) is the 35 | recommended way to install libraries**, including Airship Scheme's 36 | dependencies. All of the dependencies are either available in 37 | Quicklisp or are easily added to `local-projects` in the same way as 38 | Airship Scheme. 39 | 40 | **Note:** Portacle and Roswell already come with Quicklisp bundled. 41 | 42 | Step 3A: Manually Add Airship Scheme 43 | ------------------------------------ 44 | 45 | *Airship Scheme itself is currently not available in Quicklisp. When 46 | Airship Scheme is available in Quicklisp, these instructions will only 47 | be required to install the up-to-date git version of Airship Scheme, 48 | which will override the version in Quicklisp.* 49 | 50 | Download this git repository and make it recognizable to Quicklisp as 51 | a "local project" in your local projects directory, which might be 52 | located at `~/quicklisp/local-projects/`. 53 | 54 | Instructions on how to make airship-scheme a Quicklisp local project 55 | are available 56 | [here](https://www.quicklisp.org/beta/faq.html#local-project) and 57 | [here](http://blog.quicklisp.org/2018/01/the-quicklisp-local-projects-mechanism.html). 58 | 59 | The dependency `zr-utils` also needs to be downloaded. Everything else 60 | is in Quicklisp. The fastest way to do so is to go to your 61 | `local-projects` directory and run: 62 | 63 | ```sh 64 | git clone https://gitlab.com/zombie-raptor/zr-utils.git 65 | git clone https://gitlab.com/mbabich/airship-scheme.git 66 | ``` 67 | 68 | **Note:** You can create a symbolic link to the project directory in 69 | the Quicklisp local-projects directory. Quicklisp will follow links in 70 | most implementations, but it has been reported that this does not work 71 | for CCL. If this doesn't work, then manually editing 72 | `~/quicklisp/local-projects/system-index.txt` should work. 73 | 74 | Step 3B: Quickload Airship Scheme 75 | --------------------------------- 76 | 77 | At this point, you should be able to run the following command in the 78 | Common Lisp REPL: 79 | 80 | ```common-lisp 81 | (ql:quickload :airship-scheme) 82 | ``` 83 | 84 | Now every dependency will be loaded and after that Airship Scheme 85 | itself will load. 86 | 87 | *At this point, a way to switch into the Airship Scheme REPL would be 88 | a nice feature to add, when the REPL is functioning. Direct access to 89 | Airship Scheme via SLIME and/or Geiser in Emacs would be nice features 90 | to have, too.* 91 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016-2024 Michael Babich 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Airship Scheme 2 | ============== 3 | 4 | A new r7rs Scheme implementation, designed to run within a Common Lisp 5 | environment. 6 | 7 | On IRC 8 | ------ 9 | 10 | Airship Scheme now is on IRC! This project uses 11 | [`irc.libera.chat`](https://libera.chat/) as its IRC network. The main 12 | channel is `#airship`, but `#scheme` and `#lisp` also might be useful. 13 | 14 | About the name 15 | -------------- 16 | 17 | The name was inspired by [the "Imperial Airship Scheme" Wikipedia 18 | article](https://en.wikipedia.org/wiki/Imperial_Airship_Scheme), via 19 | [a comment someone else made on Hacker 20 | News](https://news.ycombinator.com/item?id=13868549) in early 2017. 21 | Prior to that, this project used the working title `cl-scheme`. The 22 | old name is more descriptive, but considerably less interesting. The 23 | `#scheme` channel on Freenode IRC loved the name, which was shortened 24 | to "Airship Scheme" for simplicity. 25 | 26 | Note 27 | ---- 28 | 29 | The primary repository is located 30 | [here](https://gitlab.com/mbabich/airship-scheme). Progress towards 31 | completion is measured under the [milestones 32 | here](https://gitlab.com/mbabich/airship-scheme/-/milestones). 33 | 34 | Overview 35 | -------- 36 | 37 | Airship Scheme is a new implementation of the Scheme programming 38 | language, implemented in Common Lisp and designed to run within a 39 | Common Lisp environment. The embedded nature of this architecture 40 | allows programs to run both Scheme and Common Lisp code in the same 41 | runtime. 42 | 43 | There are many existing implementations that compile Scheme to 44 | languages like C or JavaScript. With the choice of Common Lisp, the 45 | host language already contains many elements that Scheme requires. The 46 | host CL's data structures include the cons cell (or cons pair) data 47 | structure and the numeric tower, both of which can be used in the 48 | Scheme itself. 49 | 50 | On the other hand, the Scheme to CL compilation process is no longer 51 | as trivial as it was in the days of 52 | [Pseudoscheme](http://mumble.net/~jar/pseudoscheme/) because Common 53 | Lisp and Scheme have drifted further apart as languages over the past 54 | few decades, making some of the assumptions of past approaches no 55 | longer viable. There are also syntactic incompatibilities, meaning 56 | that a fully conforming Scheme cannot simply use the host CL's reader. 57 | 58 | Status 59 | ------ 60 | 61 | This project depends on sharing a large amount of code initially 62 | written for a Common Lisp first person 3D game engine called Zombie 63 | Raptor. Parts of that effort were spun off into the `zr-utils` utility 64 | library, which is a work in progress library with an unstable API. In 65 | fact, that library was spun off precisely to be used as a shared 66 | dependency between the game engine and this project. All of these are 67 | still incomplete. 68 | 69 | As of 2024, most of the recent work towards this project has been 70 | written as general purpose programming language internals instead of 71 | happening directly in this repository. In particular, there's also a 72 | vector and shader language, ZRVL, which is of more direct importance 73 | to the game engine. The smaller scope of this other language means 74 | that it is a more suitable place to develop the shared internals of 75 | programming languages that target Common Lisp implementations as a CPU 76 | runtime. Additionally, ZRVL will also target SPIR-V to be used for 77 | graphics shaders, but the semantics of Scheme would make it 78 | challenging to do so without subsetting the language. 79 | 80 | Work on this project will resume when the internals of ZRVL are spun 81 | off as a useful intermediate representation that Airship Scheme can 82 | also benefit from. 83 | 84 | Why use this project? 85 | --------------------- 86 | 87 | This project is primarily aimed at both Common Lispers and Schemers. 88 | 89 | ### For Common Lispers 90 | 91 | It offers Scheme as a convenient library: it's no harder to install or 92 | use than any other CL library. Most Scheme libraries will be usable in 93 | Common Lisp, and a lot of core-or-SRFI Scheme functionality will be 94 | provided in a CL-compatible form. Custom sequences not found in CL 95 | will be implemented via `trivial-extensible-sequences`. Eventually, a 96 | reader macro could be provided that provides most of the benefits of 97 | Scheme's additional syntax while still using the CL reader. 98 | 99 | ### For Schemers 100 | 101 | It offers the potential of getting a high-performance implementation 102 | for "free" by taking advantage of high-performance CL compilers like 103 | SBCL. Schemers will be able to wrap libraries written in CL, which 104 | will more than double the number of libraries available. These wrapped 105 | CL libraries will feel a lot "Lispier" than wrapped C libraries 106 | because CL is a closely related programming language. Additionally, 107 | almost all of the Common Lisp standard library will be wrapped. 108 | 109 | Installing 110 | ---------- 111 | 112 | See [INSTALL.md](INSTALL.md) for complete installation instructions. 113 | 114 | Quickstart 115 | ---------- 116 | 117 | The fastest way to get a Common Lisp development environment for 118 | someone who doesn't currently have one is to install 119 | [Portacle](https://portacle.github.io/). 120 | 121 | Then, inside of the Quicklisp `local-projects` directory: 122 | 123 | ```sh 124 | git clone https://gitlab.com/zombie-raptor/zr-utils.git 125 | git clone https://gitlab.com/mbabich/airship-scheme.git 126 | ``` 127 | 128 | Then you can run this at the Common Lisp REPL: 129 | 130 | ```lisp 131 | (ql:quickload :airship-scheme) 132 | ``` 133 | 134 | Contributing 135 | ------------ 136 | 137 | See [CONTRIBUTING.md](CONTRIBUTING.md) for contributing, terminology, 138 | and style guidelines. 139 | 140 | License 141 | ------- 142 | 143 | MIT License. See [LICENSE.txt](LICENSE.txt) for the license text. 144 | 145 | Using Airship Scheme 146 | -------------------- 147 | 148 | *This section is currently incomplete because the programming language 149 | is not functional at the moment.* 150 | -------------------------------------------------------------------------------- /SRFI.md: -------------------------------------------------------------------------------- 1 | # SRFIs and Related Libraries 2 | 3 | ## SRFIs 4 | 5 | | [SRFI] | Status? | R7RS name | 6 | | -------------- | :----------------------: | ------------------------------------------- | 7 | | [SRFI 0] | | *replaced in [R7RS-small]* | 8 | | [SRFI 1] | Unimplemented | `(scheme list)` | 9 | | [SRFI 2] | | | 10 | | ~~[SRFI 3]~~ | *Withdrawn* | | 11 | | [SRFI 4] | | | 12 | | [SRFI 5] | | | 13 | | **[SRFI 6]** | **[R7RS-small]** | *[R7RS-small]* | 14 | | [SRFI 7] | | | 15 | | [SRFI 8] | | | 16 | | **[SRFI 9]** | **[R7RS-small]** | *[R7RS-small]* | 17 | | [SRFI 10] | | | 18 | | [SRFI 11] | | | 19 | | ~~[SRFI 12]~~ | *Withdrawn* | | 20 | | [SRFI 13] | | | 21 | | [SRFI 14] | Unimplemented | `(scheme charset)` | 22 | | ~~[SRFI 15]~~ | *Withdrawn* | | 23 | | [SRFI 16] | | | 24 | | [SRFI 17] | | | 25 | | [SRFI 18] | | | 26 | | [SRFI 19] | | | 27 | | ~~[SRFI 20]~~ | *Withdrawn* | | 28 | | [SRFI 21] | | | 29 | | [SRFI 22] | | | 30 | | [SRFI 23] | | | 31 | | ~~[SRFI 24]~~ | *Withdrawn* | | 32 | | [SRFI 25] | | | 33 | | [SRFI 26] | | | 34 | | [SRFI 27] | | | 35 | | [SRFI 28] | | | 36 | | [SRFI 29] | | | 37 | | **[SRFI 30]** | **[R7RS-small]** | *[R7RS-small]* | 38 | | [SRFI 31] | | | 39 | | ~~[SRFI 32]~~ | *Withdrawn* | | 40 | | ~~[SRFI 33]~~ | *Withdrawn* | | 41 | | [SRFI 34] | | | 42 | | [SRFI 35] | | | 43 | | [SRFI 36] | | | 44 | | [SRFI 37] | | | 45 | | **[SRFI 38]** | **[R7RS-small]** | *[R7RS-small]* | 46 | | [SRFI 39] | | | 47 | | ~~[SRFI 40]~~ | *Withdrawn* | | 48 | | [SRFI 41] | Unimplemented | `(scheme stream)` | 49 | | [SRFI 42] | | | 50 | | [SRFI 43] | | *R7RS uses [SRFI 133]* | 51 | | [SRFI 44] | | | 52 | | [SRFI 45] | | | 53 | | [SRFI 46] | | | 54 | | [SRFI 47] | | | 55 | | [SRFI 48] | | | 56 | | [SRFI 49] | | | 57 | | ~~[SRFI 50]~~ | *Withdrawn* | | 58 | | [SRFI 51] | | | 59 | | ~~[SRFI 52]~~ | *Withdrawn* | | 60 | | ~~[SRFI 53]~~ | *Withdrawn* | | 61 | | [SRFI 54] | | | 62 | | [SRFI 55] | | | 63 | | ~~[SRFI 56]~~ | *Withdrawn* | | 64 | | [SRFI 57] | | | 65 | | [SRFI 58] | | | 66 | | [SRFI 59] | | | 67 | | [SRFI 60] | | | 68 | | [SRFI 61] | | | 69 | | **[SRFI 62]** | **[R7RS-small]** | *[R7RS-small]* | 70 | | [SRFI 63] | | | 71 | | [SRFI 64] | | | 72 | | ~~[SRFI 65]~~ | *Withdrawn* | | 73 | | [SRFI 66] | | | 74 | | [SRFI 67] | | | 75 | | ~~[SRFI 68]~~ | *Withdrawn* | | 76 | | [SRFI 69] | | | 77 | | [SRFI 70] | | | 78 | | [SRFI 71] | | | 79 | | [SRFI 72] | | | 80 | | ~~[SRFI 73]~~ | *Withdrawn* | | 81 | | [SRFI 74] | | | 82 | | ~~[SRFI 75]~~ | *Withdrawn* | | 83 | | ~~[SRFI 76]~~ | *Withdrawn* | | 84 | | ~~[SRFI 77]~~ | *Withdrawn* | | 85 | | [SRFI 78] | | | 86 | | ~~[SRFI 79]~~ | *Withdrawn* | | 87 | | ~~[SRFI 80]~~ | *Withdrawn* | | 88 | | ~~[SRFI 81]~~ | *Withdrawn* | | 89 | | ~~[SRFI 82]~~ | *Withdrawn* | | 90 | | ~~[SRFI 83]~~ | *Withdrawn* | | 91 | | ~~[SRFI 84]~~ | *Withdrawn* | | 92 | | ~~[SRFI 85]~~ | *Withdrawn* | | 93 | | [SRFI 86] | | | 94 | | **[SRFI 87]** | **[R7RS-small]** | *[R7RS-small]* | 95 | | [SRFI 88] | | | 96 | | [SRFI 89] | | | 97 | | [SRFI 90] | | | 98 | | ~~[SRFI 91]~~ | *Withdrawn* | | 99 | | ~~[SRFI 92]~~ | *Withdrawn* | | 100 | | ~~[SRFI 93]~~ | *Withdrawn* | | 101 | | [SRFI 94] | | | 102 | | [SRFI 95] | | | 103 | | [SRFI 96] | | | 104 | | [SRFI 97] | | | 105 | | **[SRFI 98]** | **[R7RS-small]** | *[R7RS-small]* | 106 | | [SRFI 99] | | | 107 | | [SRFI 100] | | | 108 | | [SRFI 101] | Unimplemented | `(scheme rlist)` | 109 | | ~~[SRFI 102]~~ | *Withdrawn* | | 110 | | ~~[SRFI 103]~~ | *Withdrawn* | | 111 | | ~~[SRFI 104]~~ | *Withdrawn* | | 112 | | [SRFI 105] | | | 113 | | [SRFI 106] | | | 114 | | [SRFI 107] | | | 115 | | [SRFI 108] | | | 116 | | [SRFI 109] | | | 117 | | [SRFI 110] | | | 118 | | [SRFI 111] | Unimplemented | `(scheme box)` | 119 | | **[SRFI 112]** | **Implemented** | | 120 | | [SRFI 113] | Unimplemented | `(scheme set)` | 121 | | ~~[SRFI 114]~~ | *Withdrawn* | | 122 | | [SRFI 115] | Unimplemented | `(scheme regex)` | 123 | | [SRFI 116] | Unimplemented | `(scheme ilist)` | 124 | | [SRFI 117] | Unimplemented | `(scheme list-queue)` | 125 | | [SRFI 118] | | | 126 | | [SRFI 119] | | | 127 | | [SRFI 120] | | | 128 | | ~~[SRFI 121]~~ | *Withdrawn* | | 129 | | [SRFI 122] | | | 130 | | [SRFI 123] | | | 131 | | [SRFI 124] | Unimplemented | `(scheme ephemeron)` | 132 | | [SRFI 125] | Unimplemented | `(scheme hash-table)` | 133 | | [SRFI 126] | | | 134 | | [SRFI 127] | Unimplemented | `(scheme lseq)` | 135 | | [SRFI 128] | Unimplemented | `(scheme comparator)` | 136 | | [SRFI 129] | | | 137 | | [SRFI 130] | | | 138 | | [SRFI 131] | | | 139 | | [SRFI 132] | Unimplemented | `(scheme sort)` | 140 | | [SRFI 133] | Unimplemented | `(scheme vector)` | 141 | | [SRFI 134] | Unimplemented | `(scheme ideque)` | 142 | | [SRFI 135] | Unimplemented | `(scheme text)` | 143 | | [SRFI 136] | | | 144 | | [SRFI 137] | | | 145 | | [SRFI 138] | | | 146 | | [SRFI 139] | | | 147 | | [SRFI 140] | | | 148 | | [SRFI 141] | Unimplemented | `(scheme division)` | 149 | | ~~[SRFI 142]~~ | *Withdrawn* | | 150 | | [SRFI 143] | Unimplemented | `(scheme fixnum)` | 151 | | [SRFI 144] | Unimplemented | `(scheme flonum)` | 152 | | [SRFI 145] | | | 153 | | [SRFI 146] | Unimplemented | `(scheme mapping)`, `(scheme mapping hash)` | 154 | | [SRFI 147] | | | 155 | | [SRFI 148] | | | 156 | | [SRFI 149] | | | 157 | | [SRFI 150] | | | 158 | | [SRFI 151] | Unimplemented | `(scheme bitwise)` | 159 | | [SRFI 152] | | | 160 | | ~~[SRFI 153]~~ | *Withdrawn* | | 161 | | [SRFI 154] | | | 162 | | [SRFI 155] | | | 163 | | [SRFI 156] | | | 164 | | [SRFI 157] | | | 165 | | [SRFI 158] | Unimplemented | `(scheme generator)` | 166 | | ~~[SRFI 159]~~ | *Withdrawn* | `(scheme show)` | 167 | | [SRFI 160] | Unimplemented | `(scheme vector @)` | 168 | | [SRFI 161] | | | 169 | | [SRFI 162] | | | 170 | | [SRFI 163] | | | 171 | | [SRFI 164] | | | 172 | | [SRFI 165] | | | 173 | | [SRFI 166] | Unimplemented | the new `(scheme show)`? | 174 | | [SRFI 167] | | | 175 | | [SRFI 168] | | | 176 | | [SRFI 169] | | | 177 | | [SRFI 170] | | | 178 | | [SRFI 171] | | | 179 | | **[SRFI 172]** | **Implemented** | | 180 | | [SRFI 173] | | | 181 | | [SRFI 174] | | | 182 | | [SRFI 175] | | | 183 | | [SRFI 176] | | | 184 | | ~~[SRFI 177]~~ | *Withdrawn* | | 185 | | [SRFI 178] | | | 186 | | [SRFI 179] | | | 187 | | [SRFI 180] | | | 188 | | [SRFI 181] | | | 189 | | ~~[SRFI 182]~~ | *Withdrawn* | | 190 | | ~~[SRFI 183]~~ | *Withdrawn* | | 191 | | ~~[SRFI 184]~~ | *Withdrawn* | | 192 | | [SRFI 185] | | | 193 | | ~~[SRFI 186]~~ | *Withdrawn* | | 194 | | ~~[SRFI 187]~~ | *Withdrawn* | | 195 | | [SRFI 188] | | | 196 | | [SRFI 189] | | | 197 | | [SRFI 190] | | | 198 | | ~~[SRFI 191]~~ | *Withdrawn* | | 199 | | [SRFI 192] | | | 200 | | [SRFI 193] | | | 201 | | [SRFI 194] | | | 202 | | [SRFI 195] | | | 203 | | [SRFI 196] | | | 204 | | [SRFI 197] | | | 205 | | ~~[SRFI 198]~~ | *Withdrawn* | | 206 | | ~~[SRFI 199]~~ | *Withdrawn* | | 207 | | [SRFI 200] | Draft | | 208 | | [SRFI 201] | Draft | | 209 | | [SRFI 202] | | | 210 | | [SRFI 203] | | | 211 | | [SRFI 204] | Draft | | 212 | | [SRFI 205] | Draft | | 213 | | [SRFI 206] | Draft | | 214 | | [SRFI 207] | | | 215 | | [SRFI 208] | Draft | | 216 | | [SRFI 209] | | | 217 | | [SRFI 210] | Draft | | 218 | | [SRFI 211] | Draft | | 219 | | [SRFI 212] | Draft | | 220 | | [SRFI 213] | Draft | | 221 | | [SRFI 214] | Draft | | 222 | | [SRFI 215] | Draft | | 223 | | [SRFI 216] | Draft | | 224 | | [SRFI 217] | Draft | | 225 | | [SRFI 218] | Draft | | 226 | | [SRFI 219] | Draft | | 227 | 228 | ## Non-SRFIs in [R7RS-large] 229 | 230 | | Library | Status? | R7RS name | 231 | | ------------------ | :------------: | --------------------- | 232 | | [R6RS bytevectors] | Unimplemented | `(scheme bytevector)` | 233 | 234 | ## [R7RS-large] 235 | 236 | | Library | Status? | R7RS name | 237 | | ------------------ | :--------------: | ------------------------------------------- | 238 | | [SRFI 1] | Unimplemented | `(scheme list)` | 239 | | **[SRFI 6]** | **[R7RS-small]** | *[R7RS-small]* | 240 | | **[SRFI 9]** | **[R7RS-small]** | *[R7RS-small]* | 241 | | [SRFI 14] | Unimplemented | `(scheme charset)` | 242 | | **[SRFI 30]** | **[R7RS-small]** | *[R7RS-small]* | 243 | | **[SRFI 38]** | **[R7RS-small]** | *[R7RS-small]* | 244 | | [SRFI 41] | Unimplemented | `(scheme stream)` | 245 | | **[SRFI 62]** | **[R7RS-small]** | *[R7RS-small]* | 246 | | **[SRFI 87]** | **[R7RS-small]** | *[R7RS-small]* | 247 | | **[SRFI 98]** | **[R7RS-small]** | *[R7RS-small]* | 248 | | [SRFI 101] | Unimplemented | `(scheme rlist)` | 249 | | [SRFI 111] | Unimplemented | `(scheme box)` | 250 | | [SRFI 113] | Unimplemented | `(scheme set)` | 251 | | [SRFI 115] | Unimplemented | `(scheme regex)` | 252 | | [SRFI 116] | Unimplemented | `(scheme ilist)` | 253 | | [SRFI 117] | Unimplemented | `(scheme list-queue)` | 254 | | [SRFI 124] | Unimplemented | `(scheme ephemeron)` | 255 | | [SRFI 125] | Unimplemented | `(scheme hash-table)` | 256 | | [SRFI 127] | Unimplemented | `(scheme lseq)` | 257 | | [SRFI 128] | Unimplemented | `(scheme comparator)` | 258 | | [SRFI 132] | Unimplemented | `(scheme sort)` | 259 | | [SRFI 133] | Unimplemented | `(scheme vector)` | 260 | | [SRFI 134] | Unimplemented | `(scheme ideque)` | 261 | | [SRFI 135] | Unimplemented | `(scheme text)` | 262 | | [SRFI 141] | Unimplemented | `(scheme division)` | 263 | | [SRFI 143] | Unimplemented | `(scheme fixnum)` | 264 | | [SRFI 144] | Unimplemented | `(scheme flonum)` | 265 | | [SRFI 146] | Unimplemented | `(scheme mapping)`, `(scheme mapping hash)` | 266 | | [SRFI 151] | Unimplemented | `(scheme bitwise)` | 267 | | [SRFI 158] | Unimplemented | `(scheme generator)` | 268 | | [SRFI 159] | Unimplemented | `(scheme show)` | 269 | | [SRFI 160] | Unimplemented | `(scheme vector @)` | 270 | | [R6RS bytevectors] | Unimplemented | `(scheme bytevector)` | 271 | 272 | [R7RS-small]: https://small.r7rs.org/attachment/r7rs.pdf 273 | [R7RS-large]: https://bitbucket.org/cowan/r7rs-wg1-infra/src/default/R7RSHomePage.md 274 | [SRFI]: https://srfi.schemers.org/ 275 | [SRFI 0]: https://srfi.schemers.org/srfi-0/srfi-0.html 276 | [SRFI 1]: https://srfi.schemers.org/srfi-1/srfi-1.html 277 | [SRFI 2]: https://srfi.schemers.org/srfi-2/srfi-2.html 278 | [SRFI 3]: https://srfi.schemers.org/srfi-3/srfi-3.html 279 | [SRFI 4]: https://srfi.schemers.org/srfi-4/srfi-4.html 280 | [SRFI 5]: https://srfi.schemers.org/srfi-5/srfi-5.html 281 | [SRFI 6]: https://srfi.schemers.org/srfi-6/srfi-6.html 282 | [SRFI 7]: https://srfi.schemers.org/srfi-7/srfi-7.html 283 | [SRFI 8]: https://srfi.schemers.org/srfi-8/srfi-8.html 284 | [SRFI 9]: https://srfi.schemers.org/srfi-9/srfi-9.html 285 | [SRFI 10]: https://srfi.schemers.org/srfi-10/srfi-10.html 286 | [SRFI 11]: https://srfi.schemers.org/srfi-11/srfi-11.html 287 | [SRFI 12]: https://srfi.schemers.org/srfi-12/srfi-12.html 288 | [SRFI 13]: https://srfi.schemers.org/srfi-13/srfi-13.html 289 | [SRFI 14]: https://srfi.schemers.org/srfi-14/srfi-14.html 290 | [SRFI 15]: https://srfi.schemers.org/srfi-15/srfi-15.html 291 | [SRFI 16]: https://srfi.schemers.org/srfi-16/srfi-16.html 292 | [SRFI 17]: https://srfi.schemers.org/srfi-17/srfi-17.html 293 | [SRFI 18]: https://srfi.schemers.org/srfi-18/srfi-18.html 294 | [SRFI 19]: https://srfi.schemers.org/srfi-19/srfi-19.html 295 | [SRFI 20]: https://srfi.schemers.org/srfi-20/srfi-20.html 296 | [SRFI 21]: https://srfi.schemers.org/srfi-21/srfi-21.html 297 | [SRFI 22]: https://srfi.schemers.org/srfi-22/srfi-22.html 298 | [SRFI 23]: https://srfi.schemers.org/srfi-23/srfi-23.html 299 | [SRFI 24]: https://srfi.schemers.org/srfi-24/srfi-24.html 300 | [SRFI 25]: https://srfi.schemers.org/srfi-25/srfi-25.html 301 | [SRFI 26]: https://srfi.schemers.org/srfi-26/srfi-26.html 302 | [SRFI 27]: https://srfi.schemers.org/srfi-27/srfi-27.html 303 | [SRFI 28]: https://srfi.schemers.org/srfi-28/srfi-28.html 304 | [SRFI 29]: https://srfi.schemers.org/srfi-29/srfi-29.html 305 | [SRFI 30]: https://srfi.schemers.org/srfi-30/srfi-30.html 306 | [SRFI 31]: https://srfi.schemers.org/srfi-31/srfi-31.html 307 | [SRFI 32]: https://srfi.schemers.org/srfi-32/srfi-32.html 308 | [SRFI 33]: https://srfi.schemers.org/srfi-33/srfi-33.html 309 | [SRFI 34]: https://srfi.schemers.org/srfi-34/srfi-34.html 310 | [SRFI 35]: https://srfi.schemers.org/srfi-35/srfi-35.html 311 | [SRFI 36]: https://srfi.schemers.org/srfi-36/srfi-36.html 312 | [SRFI 37]: https://srfi.schemers.org/srfi-37/srfi-37.html 313 | [SRFI 38]: https://srfi.schemers.org/srfi-38/srfi-38.html 314 | [SRFI 39]: https://srfi.schemers.org/srfi-39/srfi-39.html 315 | [SRFI 40]: https://srfi.schemers.org/srfi-40/srfi-40.html 316 | [SRFI 41]: https://srfi.schemers.org/srfi-41/srfi-41.html 317 | [SRFI 42]: https://srfi.schemers.org/srfi-42/srfi-42.html 318 | [SRFI 43]: https://srfi.schemers.org/srfi-43/srfi-43.html 319 | [SRFI 44]: https://srfi.schemers.org/srfi-44/srfi-44.html 320 | [SRFI 45]: https://srfi.schemers.org/srfi-45/srfi-45.html 321 | [SRFI 46]: https://srfi.schemers.org/srfi-46/srfi-46.html 322 | [SRFI 47]: https://srfi.schemers.org/srfi-47/srfi-47.html 323 | [SRFI 48]: https://srfi.schemers.org/srfi-48/srfi-48.html 324 | [SRFI 49]: https://srfi.schemers.org/srfi-49/srfi-49.html 325 | [SRFI 50]: https://srfi.schemers.org/srfi-50/srfi-50.html 326 | [SRFI 51]: https://srfi.schemers.org/srfi-51/srfi-51.html 327 | [SRFI 52]: https://srfi.schemers.org/srfi-52/srfi-52.html 328 | [SRFI 53]: https://srfi.schemers.org/srfi-53/srfi-53.html 329 | [SRFI 54]: https://srfi.schemers.org/srfi-54/srfi-54.html 330 | [SRFI 55]: https://srfi.schemers.org/srfi-55/srfi-55.html 331 | [SRFI 56]: https://srfi.schemers.org/srfi-56/srfi-56.html 332 | [SRFI 57]: https://srfi.schemers.org/srfi-57/srfi-57.html 333 | [SRFI 58]: https://srfi.schemers.org/srfi-58/srfi-58.html 334 | [SRFI 59]: https://srfi.schemers.org/srfi-59/srfi-59.html 335 | [SRFI 60]: https://srfi.schemers.org/srfi-60/srfi-60.html 336 | [SRFI 61]: https://srfi.schemers.org/srfi-61/srfi-61.html 337 | [SRFI 62]: https://srfi.schemers.org/srfi-62/srfi-62.html 338 | [SRFI 63]: https://srfi.schemers.org/srfi-63/srfi-63.html 339 | [SRFI 64]: https://srfi.schemers.org/srfi-64/srfi-64.html 340 | [SRFI 65]: https://srfi.schemers.org/srfi-65/srfi-65.html 341 | [SRFI 66]: https://srfi.schemers.org/srfi-66/srfi-66.html 342 | [SRFI 67]: https://srfi.schemers.org/srfi-67/srfi-67.html 343 | [SRFI 68]: https://srfi.schemers.org/srfi-68/srfi-68.html 344 | [SRFI 69]: https://srfi.schemers.org/srfi-69/srfi-69.html 345 | [SRFI 70]: https://srfi.schemers.org/srfi-70/srfi-70.html 346 | [SRFI 71]: https://srfi.schemers.org/srfi-71/srfi-71.html 347 | [SRFI 72]: https://srfi.schemers.org/srfi-72/srfi-72.html 348 | [SRFI 73]: https://srfi.schemers.org/srfi-73/srfi-73.html 349 | [SRFI 74]: https://srfi.schemers.org/srfi-74/srfi-74.html 350 | [SRFI 75]: https://srfi.schemers.org/srfi-75/srfi-75.html 351 | [SRFI 76]: https://srfi.schemers.org/srfi-76/srfi-76.html 352 | [SRFI 77]: https://srfi.schemers.org/srfi-77/srfi-77.html 353 | [SRFI 78]: https://srfi.schemers.org/srfi-78/srfi-78.html 354 | [SRFI 79]: https://srfi.schemers.org/srfi-79/srfi-79.html 355 | [SRFI 80]: https://srfi.schemers.org/srfi-80/srfi-80.html 356 | [SRFI 81]: https://srfi.schemers.org/srfi-81/srfi-81.html 357 | [SRFI 82]: https://srfi.schemers.org/srfi-82/srfi-82.html 358 | [SRFI 83]: https://srfi.schemers.org/srfi-83/srfi-83.html 359 | [SRFI 84]: https://srfi.schemers.org/srfi-84/srfi-84.html 360 | [SRFI 85]: https://srfi.schemers.org/srfi-85/srfi-85.html 361 | [SRFI 86]: https://srfi.schemers.org/srfi-86/srfi-86.html 362 | [SRFI 87]: https://srfi.schemers.org/srfi-87/srfi-87.html 363 | [SRFI 88]: https://srfi.schemers.org/srfi-88/srfi-88.html 364 | [SRFI 89]: https://srfi.schemers.org/srfi-89/srfi-89.html 365 | [SRFI 90]: https://srfi.schemers.org/srfi-90/srfi-90.html 366 | [SRFI 91]: https://srfi.schemers.org/srfi-91/srfi-91.html 367 | [SRFI 92]: https://srfi.schemers.org/srfi-92/srfi-92.html 368 | [SRFI 93]: https://srfi.schemers.org/srfi-93/srfi-93.html 369 | [SRFI 94]: https://srfi.schemers.org/srfi-94/srfi-94.html 370 | [SRFI 95]: https://srfi.schemers.org/srfi-95/srfi-95.html 371 | [SRFI 96]: https://srfi.schemers.org/srfi-96/srfi-96.html 372 | [SRFI 97]: https://srfi.schemers.org/srfi-97/srfi-97.html 373 | [SRFI 98]: https://srfi.schemers.org/srfi-98/srfi-98.html 374 | [SRFI 99]: https://srfi.schemers.org/srfi-99/srfi-99.html 375 | [SRFI 100]: https://srfi.schemers.org/srfi-100/srfi-100.html 376 | [SRFI 101]: https://srfi.schemers.org/srfi-101/srfi-101.html 377 | [SRFI 102]: https://srfi.schemers.org/srfi-102/srfi-102.html 378 | [SRFI 103]: https://srfi.schemers.org/srfi-103/srfi-103.html 379 | [SRFI 104]: https://srfi.schemers.org/srfi-104/srfi-104.html 380 | [SRFI 105]: https://srfi.schemers.org/srfi-105/srfi-105.html 381 | [SRFI 106]: https://srfi.schemers.org/srfi-106/srfi-106.html 382 | [SRFI 107]: https://srfi.schemers.org/srfi-107/srfi-107.html 383 | [SRFI 108]: https://srfi.schemers.org/srfi-108/srfi-108.html 384 | [SRFI 109]: https://srfi.schemers.org/srfi-109/srfi-109.html 385 | [SRFI 110]: https://srfi.schemers.org/srfi-110/srfi-110.html 386 | [SRFI 111]: https://srfi.schemers.org/srfi-111/srfi-111.html 387 | [SRFI 112]: https://srfi.schemers.org/srfi-112/srfi-112.html 388 | [SRFI 113]: https://srfi.schemers.org/srfi-113/srfi-113.html 389 | [SRFI 114]: https://srfi.schemers.org/srfi-114/srfi-114.html 390 | [SRFI 115]: https://srfi.schemers.org/srfi-115/srfi-115.html 391 | [SRFI 116]: https://srfi.schemers.org/srfi-116/srfi-116.html 392 | [SRFI 117]: https://srfi.schemers.org/srfi-117/srfi-117.html 393 | [SRFI 118]: https://srfi.schemers.org/srfi-118/srfi-118.html 394 | [SRFI 119]: https://srfi.schemers.org/srfi-119/srfi-119.html 395 | [SRFI 120]: https://srfi.schemers.org/srfi-120/srfi-120.html 396 | [SRFI 121]: https://srfi.schemers.org/srfi-121/srfi-121.html 397 | [SRFI 122]: https://srfi.schemers.org/srfi-122/srfi-122.html 398 | [SRFI 123]: https://srfi.schemers.org/srfi-123/srfi-123.html 399 | [SRFI 124]: https://srfi.schemers.org/srfi-124/srfi-124.html 400 | [SRFI 125]: https://srfi.schemers.org/srfi-125/srfi-125.html 401 | [SRFI 126]: https://srfi.schemers.org/srfi-126/srfi-126.html 402 | [SRFI 127]: https://srfi.schemers.org/srfi-127/srfi-127.html 403 | [SRFI 128]: https://srfi.schemers.org/srfi-128/srfi-128.html 404 | [SRFI 129]: https://srfi.schemers.org/srfi-129/srfi-129.html 405 | [SRFI 130]: https://srfi.schemers.org/srfi-130/srfi-130.html 406 | [SRFI 131]: https://srfi.schemers.org/srfi-131/srfi-131.html 407 | [SRFI 132]: https://srfi.schemers.org/srfi-132/srfi-132.html 408 | [SRFI 133]: https://srfi.schemers.org/srfi-133/srfi-133.html 409 | [SRFI 134]: https://srfi.schemers.org/srfi-134/srfi-134.html 410 | [SRFI 135]: https://srfi.schemers.org/srfi-135/srfi-135.html 411 | [SRFI 136]: https://srfi.schemers.org/srfi-136/srfi-136.html 412 | [SRFI 137]: https://srfi.schemers.org/srfi-137/srfi-137.html 413 | [SRFI 138]: https://srfi.schemers.org/srfi-138/srfi-138.html 414 | [SRFI 139]: https://srfi.schemers.org/srfi-139/srfi-139.html 415 | [SRFI 140]: https://srfi.schemers.org/srfi-140/srfi-140.html 416 | [SRFI 141]: https://srfi.schemers.org/srfi-141/srfi-141.html 417 | [SRFI 142]: https://srfi.schemers.org/srfi-142/srfi-142.html 418 | [SRFI 143]: https://srfi.schemers.org/srfi-143/srfi-143.html 419 | [SRFI 144]: https://srfi.schemers.org/srfi-144/srfi-144.html 420 | [SRFI 145]: https://srfi.schemers.org/srfi-145/srfi-145.html 421 | [SRFI 146]: https://srfi.schemers.org/srfi-146/srfi-146.html 422 | [SRFI 147]: https://srfi.schemers.org/srfi-147/srfi-147.html 423 | [SRFI 148]: https://srfi.schemers.org/srfi-148/srfi-148.html 424 | [SRFI 149]: https://srfi.schemers.org/srfi-149/srfi-149.html 425 | [SRFI 150]: https://srfi.schemers.org/srfi-150/srfi-150.html 426 | [SRFI 151]: https://srfi.schemers.org/srfi-151/srfi-151.html 427 | [SRFI 152]: https://srfi.schemers.org/srfi-152/srfi-152.html 428 | [SRFI 153]: https://srfi.schemers.org/srfi-153/srfi-153.html 429 | [SRFI 154]: https://srfi.schemers.org/srfi-154/srfi-154.html 430 | [SRFI 155]: https://srfi.schemers.org/srfi-155/srfi-155.html 431 | [SRFI 156]: https://srfi.schemers.org/srfi-156/srfi-156.html 432 | [SRFI 157]: https://srfi.schemers.org/srfi-157/srfi-157.html 433 | [SRFI 158]: https://srfi.schemers.org/srfi-158/srfi-158.html 434 | [SRFI 159]: https://srfi.schemers.org/srfi-159/srfi-159.html 435 | [SRFI 160]: https://srfi.schemers.org/srfi-160/srfi-160.html 436 | [SRFI 161]: https://srfi.schemers.org/srfi-161/srfi-161.html 437 | [SRFI 162]: https://srfi.schemers.org/srfi-162/srfi-162.html 438 | [SRFI 163]: https://srfi.schemers.org/srfi-163/srfi-163.html 439 | [SRFI 164]: https://srfi.schemers.org/srfi-164/srfi-164.html 440 | [SRFI 165]: https://srfi.schemers.org/srfi-165/srfi-165.html 441 | [SRFI 166]: https://srfi.schemers.org/srfi-166/srfi-166.html 442 | [SRFI 167]: https://srfi.schemers.org/srfi-167/srfi-167.html 443 | [SRFI 168]: https://srfi.schemers.org/srfi-168/srfi-168.html 444 | [SRFI 169]: https://srfi.schemers.org/srfi-169/srfi-169.html 445 | [SRFI 170]: https://srfi.schemers.org/srfi-170/srfi-170.html 446 | [SRFI 171]: https://srfi.schemers.org/srfi-171/srfi-171.html 447 | [SRFI 172]: https://srfi.schemers.org/srfi-172/srfi-172.html 448 | [SRFI 173]: https://srfi.schemers.org/srfi-173/srfi-173.html 449 | [SRFI 174]: https://srfi.schemers.org/srfi-174/srfi-174.html 450 | [SRFI 175]: https://srfi.schemers.org/srfi-175/srfi-175.html 451 | [SRFI 176]: https://srfi.schemers.org/srfi-176/srfi-176.html 452 | [SRFI 177]: https://srfi.schemers.org/srfi-177/srfi-177.html 453 | [SRFI 178]: https://srfi.schemers.org/srfi-178/srfi-178.html 454 | [SRFI 179]: https://srfi.schemers.org/srfi-179/srfi-179.html 455 | [SRFI 180]: https://srfi.schemers.org/srfi-180/srfi-180.html 456 | [SRFI 181]: https://srfi.schemers.org/srfi-181/srfi-181.html 457 | [SRFI 182]: https://srfi.schemers.org/srfi-182/srfi-182.html 458 | [SRFI 183]: https://srfi.schemers.org/srfi-183/srfi-183.html 459 | [SRFI 184]: https://srfi.schemers.org/srfi-184/srfi-184.html 460 | [SRFI 185]: https://srfi.schemers.org/srfi-185/srfi-185.html 461 | [SRFI 186]: https://srfi.schemers.org/srfi-186/srfi-186.html 462 | [SRFI 187]: https://srfi.schemers.org/srfi-187/srfi-187.html 463 | [SRFI 188]: https://srfi.schemers.org/srfi-188/srfi-188.html 464 | [SRFI 189]: https://srfi.schemers.org/srfi-189/srfi-189.html 465 | [SRFI 190]: https://srfi.schemers.org/srfi-190/srfi-190.html 466 | [SRFI 191]: https://srfi.schemers.org/srfi-191/srfi-191.html 467 | [SRFI 192]: https://srfi.schemers.org/srfi-192/srfi-192.html 468 | [SRFI 193]: https://srfi.schemers.org/srfi-193/srfi-193.html 469 | [SRFI 194]: https://srfi.schemers.org/srfi-194/srfi-194.html 470 | [SRFI 195]: https://srfi.schemers.org/srfi-195/srfi-195.html 471 | [SRFI 196]: https://srfi.schemers.org/srfi-196/srfi-196.html 472 | [SRFI 197]: https://srfi.schemers.org/srfi-197/srfi-197.html 473 | [SRFI 198]: https://srfi.schemers.org/srfi-198/srfi-198.html 474 | [SRFI 199]: https://srfi.schemers.org/srfi-199/srfi-199.html 475 | [SRFI 200]: https://srfi.schemers.org/srfi-200/srfi-200.html 476 | [SRFI 201]: https://srfi.schemers.org/srfi-201/srfi-201.html 477 | [SRFI 202]: https://srfi.schemers.org/srfi-202/srfi-202.html 478 | [SRFI 203]: https://srfi.schemers.org/srfi-203/srfi-203.html 479 | [SRFI 204]: https://srfi.schemers.org/srfi-204/srfi-204.html 480 | [SRFI 205]: https://srfi.schemers.org/srfi-205/srfi-205.html 481 | [SRFI 206]: https://srfi.schemers.org/srfi-205/srfi-206.html 482 | [SRFI 207]: https://srfi.schemers.org/srfi-205/srfi-207.html 483 | [SRFI 208]: https://srfi.schemers.org/srfi-205/srfi-208.html 484 | [SRFI 209]: https://srfi.schemers.org/srfi-205/srfi-209.html 485 | [SRFI 210]: https://srfi.schemers.org/srfi-205/srfi-210.html 486 | [SRFI 211]: https://srfi.schemers.org/srfi-205/srfi-211.html 487 | [SRFI 212]: https://srfi.schemers.org/srfi-205/srfi-212.html 488 | [SRFI 213]: https://srfi.schemers.org/srfi-205/srfi-213.html 489 | [SRFI 214]: https://srfi.schemers.org/srfi-205/srfi-214.html 490 | [SRFI 215]: https://srfi.schemers.org/srfi-205/srfi-215.html 491 | [SRFI 216]: https://srfi.schemers.org/srfi-205/srfi-216.html 492 | [SRFI 217]: https://srfi.schemers.org/srfi-205/srfi-217.html 493 | [SRFI 218]: https://srfi.schemers.org/srfi-205/srfi-218.html 494 | [R6RS bytevectors]: http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-3.html#node_chap_2 495 | -------------------------------------------------------------------------------- /airship-scheme.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:cl) 4 | 5 | (asdf:defsystem #:airship-scheme 6 | :serial t 7 | :description "A new r7rs Scheme implementation, designed to run within a Common Lisp environment." 8 | :version "0.0.0" 9 | :author "Michael Babich" 10 | :maintainer "Michael Babich" 11 | :license "MIT" 12 | :homepage "https://gitlab.com/mbabich/airship-scheme" 13 | :bug-tracker "https://gitlab.com/mbabich/airship-scheme/issues" 14 | :source-control (:git "https://gitlab.com/mbabich/airship-scheme.git") 15 | :depends-on (:alexandria 16 | :float-features 17 | :trivial-features 18 | :zr-utils) 19 | :components ((:file "package") 20 | (:file "scheme-boolean") 21 | (:file "util") 22 | (:file "scheme-core") 23 | (:file "scheme-types") 24 | (:file "scheme-string") 25 | (:file "equality") 26 | (:file "scheme-write") 27 | (:file "scheme-read") 28 | (:file "standard-procedures") 29 | (:file "extra-procedures") 30 | (:file "cl-macros")) 31 | :in-order-to ((asdf:test-op (asdf:test-op "airship-scheme/tests")))) 32 | 33 | (asdf:defsystem #:airship-scheme/tests 34 | :serial t 35 | :description "The tests for the Common Lisp side of Airship Scheme." 36 | :version "0.0.0" 37 | :author "Michael Babich" 38 | :maintainer "Michael Babich" 39 | :license "MIT" 40 | :depends-on (:airship-scheme 41 | :fiveam) 42 | :components ((:module "tests" 43 | :serial t 44 | :components ((:file "package") 45 | (:file "tests")))) 46 | :perform (asdf:test-op (o s) (uiop:symbol-call :fiveam 47 | :run! 48 | (cl:intern (cl:symbol-name '#:airship-scheme/tests) 49 | '#:airship-scheme/tests)))) 50 | -------------------------------------------------------------------------------- /cl-macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:airship-scheme) 2 | 3 | ;;;; This file implements Common Lisp macro equivalents for macros or 4 | ;;;; special forms that only exist inside of Scheme. This is because 5 | ;;;; Airship Scheme exists to expose Scheme functionality to Common 6 | ;;;; Lisp, not just as an implementation of Scheme inside of Common 7 | ;;;; Lisp. 8 | 9 | ;;; TODO: Also support define-function, which has no equivalent in 10 | ;;; Scheme because Scheme is a Lisp-1. This makes this macro 11 | ;;; significantly more complicated. 12 | ;;; 13 | ;;; Note that this is the internal form of BEGIN rather than the 14 | ;;; top-level form of BEGIN. 15 | (defmacro begin (&body body) 16 | " 17 | This Scheme-style macro BEGIN behaves like the Common Lisp PROGN, 18 | except any number of variable DEFINEs at the start of the BEGIN macro 19 | are turned into bindings of a LET*. The Lisp-2 nature of Common Lisp 20 | means that the DEFINE only defines variables, not functions (in 21 | Scheme, called procedures). 22 | 23 | This is actually a more powerful form of BEGIN than the Scheme 24 | standard permits because Schemes are allowed to fail on something like 25 | this: 26 | 27 | (+ (begin (define x 42) (+ x x)) 3) 28 | 29 | This is because begin-with-defines in Scheme is just passing through 30 | the defines to a place where it is potentially valid, such as a 31 | top-level form or in the body of a procedure's define or lambda. 32 | 33 | On the other hand, this macro is handling the internal defines inside 34 | of the begin itself. This will fail to behave like Scheme at the top 35 | level, but work as expected inside of things like DEFUN. It's just 36 | that it will also work in places where it might fail in some Schemes. 37 | 38 | In this sense, Common Lisp does things backwards compared to Scheme. 39 | Some Common Lisp macros have implicit PROGNs so Scheme-style macros in 40 | Common Lisp should have implicit BEGINs that behave like extended 41 | PROGNs, whereas Scheme's BEGIN just passes things through. 42 | " 43 | (loop :for sublist :on body 44 | :for item := (car sublist) 45 | :while (and (listp item) (eql (car item) 'define)) 46 | :collect (cdr item) :into bindings 47 | :finally (return 48 | `(let* ,bindings 49 | (macrolet ((define (variable &optional binding) 50 | (declare (ignore variable binding)) 51 | (error "Define must come at the beginning of a BEGIN."))) 52 | ,@sublist))))) 53 | 54 | ;;; This exists so tools like SLIME see a define inside of begin even 55 | ;;; though begin doesn't use it. Schemes have lexical, not dynamic, 56 | ;;; globals so this doesn't behave exactly like the Scheme version. It 57 | ;;; also only does variables, not functions. 58 | (defmacro define (variable &optional binding) 59 | `(defparameter ,variable ,binding)) 60 | -------------------------------------------------------------------------------- /equality.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | ;;;; Non-string equality testing 4 | ;;;; 5 | ;;;; The core three equivalents predicates are described in r7rs.pdf 6 | ;;;; section 6.1. 7 | 8 | (in-package #:airship-scheme) 9 | 10 | (define-function (%symbol= :inline t :check-type t) ((symbol-1 symbol) (symbol-2 symbol)) 11 | (eq symbol-1 symbol-2)) 12 | 13 | (defun symbol= (&rest symbols) 14 | "Tests if one or more symbols are equal to each other" 15 | (compare #'%symbol= symbols)) 16 | 17 | (defun eqv? (x y) 18 | " 19 | Tests if two objects are Scheme-equivalent to each other, using the 20 | rules provided in the r7rs-small specification. 21 | " 22 | (typecase x 23 | (symbol (typecase y (symbol (%symbol= x y)))) 24 | (inexact? (typecase y (inexact? (= x y)))) 25 | (exact? (typecase y (exact? (= x y)))) 26 | (character (typecase y (character (char= x y)))) 27 | (t (eq x y)))) 28 | 29 | ;;; TODO: If circular and equal?, then this iterates too much because 30 | ;;; it goes to the first detected part of the cycle rather than to the 31 | ;;; start of it. It can't just stop at the detection of the cycle 32 | ;;; because of e.g. '(-1 0 . #1=(1 2 3 4 5 6 7 8 9 . #1#)) 33 | (define-function list-equal? ((list1 list) (list2 list)) 34 | ;; Note: Tested in a more verbose way so that the list lengths match 35 | ;; in the ALWAYS test and so lists with cycles always terminate. 36 | (loop :with end? := nil 37 | :with cycle-x := nil 38 | :with cycle-y := nil 39 | :for x := list1 :then (cdr x) 40 | :for y := list2 :then (cdr y) 41 | ;; For cycle testing to ensure termination 42 | :for x-fast := list1 :then (cddr x-fast) 43 | :for y-fast := list2 :then (cddr y-fast) 44 | :for i :from 0 45 | :until end? 46 | ;; Recursive equality test 47 | :always (or (and (endp x) (endp y)) 48 | (equal? (car x) (car y))) 49 | :do 50 | ;; End test 51 | (when (or (endp x) (endp y) (eq x cycle-x) (eq y cycle-y)) 52 | (setf end? t)) 53 | ;; Cycle tests 54 | (when (plusp i) 55 | (when (and x-fast (not cycle-x) (eq x x-fast)) 56 | (setf cycle-x x)) 57 | (when (and y-fast (not cycle-y) (eq y y-fast)) 58 | (setf cycle-y y))))) 59 | 60 | (defun vector-equal? (x y) 61 | (and (typep y (type-of x)) 62 | (= (length x) (length y)) 63 | (loop :for a :across x 64 | :for b :across y 65 | :always (equal? a b)))) 66 | 67 | ;;; TODO: use a sequence-generic comparison when extensible-sequences is used 68 | (defun equal? (x y) 69 | (typecase x 70 | (list (and (listp y) (list-equal? x y))) 71 | (vector (and (vectorp y) (vector-equal? x y))) 72 | (t (eqv? x y)))) 73 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | Airship Scheme Examples 2 | ======================= 3 | 4 | Every program in this directory demonstrates a feature of Scheme, such 5 | as tail recursion or continuations. You should probably start by 6 | reading `hello-world.scm`, which is more of a tail recursion hello 7 | world than the simplest possible hello world for Scheme. 8 | -------------------------------------------------------------------------------- /examples/base.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | ;;; A simple library consisting of the public procedures and macros 4 | ;;; for all of the example programs. 5 | 6 | (define-library (examples base) 7 | (import (scheme base) 8 | (scheme write)) 9 | (export hello) 10 | (include "hello-world.scm")) 11 | -------------------------------------------------------------------------------- /examples/hello-world.scm: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | ;;; A simple hello world of arbitrary length implemented via tail 4 | ;;; recursion. hello* is the helper procedure to hello. The main 5 | ;;; procedure is hello, which should be called with 0 or more 6 | ;;; arguments. 7 | ;;; 8 | ;;; This demonstrates several things, including tail recursion and the 9 | ;;; use of \n in strings. 10 | 11 | (define (hello* names) 12 | (display (car names)) 13 | (if (null? (cdr names)) 14 | (display "!\n") 15 | (begin 16 | (display ", ") 17 | (hello* (cdr names))))) 18 | 19 | (define (hello . names) 20 | (if (null? names) 21 | (display "Hello world!\n") 22 | (begin 23 | (display "Hello ") 24 | (hello* names)))) 25 | -------------------------------------------------------------------------------- /examples/syntax.scm: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | ;;;; The first line is the Emacs mode line. It tells Emacs and other 4 | ;;;; tools that this file is a Scheme file. Tools should already know 5 | ;;;; that .scm files are Scheme, but it's currently needed for .sld 6 | ;;;; (R7RS library) files. 7 | 8 | ;;;; This file demonstrates the syntax of Airship Scheme, which is a 9 | ;;;; slightly extended R7RS syntax. This file has many more comments 10 | ;;;; than a typical file should have. 11 | ;;;; 12 | ;;;; Line comments start with at least one ';'. Comments on their own 13 | ;;;; line will start with ';;;;' or ';;;' if they're top 14 | ;;;; level. Generally, ';;;' comments are about the form immediately 15 | ;;;; following the comment. 16 | 17 | ;;;; Defining globals 18 | 19 | ;;;; First, let's see the global variable and global procedure 20 | ;;;; definitions. 21 | 22 | ;;; This is a global variable. It uses the `define` macro. 23 | (define a-global-variable 42) 24 | 25 | ;;; Scheme is a Lisp-1, meaning procedures (functions) and variables 26 | ;;; share the same namespace. This means that the long form of a 27 | ;;; function's definition is just a `define` followed by a `lambda`. 28 | ;;; 29 | ;;; Schemes tend to prefer the word "procedure" instead of the word 30 | ;;; "function" because it reserves the term for pure/mathematical 31 | ;;; functions, seeing the typical programming "function" that could 32 | ;;; have side effects as just a "procedure". 33 | ;;; 34 | ;;; This will also demonstrate the two other kinds of semicolon 35 | ;;; comments. Note that these are all conventions. The language itself 36 | ;;; only enforces that everything after a semicolon until the next 37 | ;;; newline is a comment. 38 | (define a-long-form-procedure 39 | ;; This comment is internal to a procedure. It only has two 40 | ;; semicolons and is meant to describe the following form. 41 | (lambda (x) ; This comment applies to the current line. 42 | (* x 42))) 43 | 44 | ;;; Scheme allows, as syntactic sugar, a slight modification of the 45 | ;;; `define` syntax to avoid the unnecessary `lambda`. 46 | ;;; 47 | ;;; Unlike most Lisps, the name of the procedure is part of the list, 48 | ;;; not just its arguments. This is how Scheme can tell the difference 49 | ;;; between a simple variable definition or the short form of a 50 | ;;; procedure definition even though both use `define`. 51 | ;;; 52 | ;;; Besides the name, this should be equivalent to the previous 53 | ;;; procedure definition. 54 | (define (a-short-form-procedure x) 55 | (* x 42)) 56 | 57 | ;;;; Other comments 58 | 59 | ;;;; We know about the semicolon, but R7RS supports a few other ways 60 | ;;;; to comment things out. 61 | 62 | ;;; The first define should not be read, but the second should be 63 | ;;; read. This is because #; will skip the next non-#; form. 64 | #; (define foobar 42) (define foobar 43) 65 | 66 | ;;; Note that #; #; shouldn't apply the first #; to skip the second 67 | ;;; #;. Instead, #; #; should skip two forms and evaluate the third. 68 | ;;; 69 | ;;; It's unlikely that your syntax highlighting can handle this. 70 | #; #; (define barfoo 42) (define barfoo 43) (define barfoo 44) 71 | 72 | ;;; There's one other way to comment in R7RS, which is the block 73 | ;;; comment syntax, which works like this: 74 | #| This isn't valid Scheme syntax but it shouldn't matter because it's 75 | in a comment. Note that this comment form also supports more than one 76 | line. A proper Scheme style prefers using the semicolon comments, 77 | though. |# 78 | 79 | ;;; This can be nested. The first |# shouldn't end the block 80 | ;;; comment. Here's an example of that: 81 | #| #| (display "Hello, world!\n") |# (display "Hello world\n") |# 82 | 83 | ;;;; Numeric syntax 84 | 85 | ;;; The following list is an example of most of the possible ways to 86 | ;;; write a number. Most of the syntactic complexity comes from 87 | ;;; complex numbers and the floating point infinities/NaNs. This 88 | ;;; latter type of syntax is called "infnan" in the R7RS-small 89 | ;;; specification. 90 | ;;; 91 | ;;; Airship Scheme uses the optional, CL-style specifiers for the 92 | ;;; different floating point types: short-float (s), single-float (f), 93 | ;;; double-float (d), and long-float (l). Airship Scheme uses the same 94 | ;;; floating point types as the host CL. Virtually every CL will have 95 | ;;; distinct single and double float types, and some will have long 96 | ;;; floats, but only a few will have short floats. 97 | ;;; 98 | ;;; Unlike in some programming languages, the exponent is required, 99 | ;;; e.g. "1f0". On the other hand, "1f" is invalid. 100 | ;;; 101 | ;;; CL defaults to single-float when no float type is specified, but 102 | ;;; the default in Scheme is double-float so a number like 4e3 or 5.0 103 | ;;; is a double-float, not a single-float. 104 | ;;; 105 | ;;; The standard is silent on how to extend the "infnan" syntax to 106 | ;;; these different floating point types. Racket uses syntax like 107 | ;;; "+inf.f" for the single-float infnan syntax, but this looks ugly 108 | ;;; and doesn't even look like a number. It also prevents extensions 109 | ;;; to the infnan syntax that permit nonzero integers after the dot. 110 | ;;; Airship Scheme uses "s0", "f0", "d0", and "l0" because this is the 111 | ;;; main way to turn regular numbers into the respective float type. 112 | ;;; The "0" means to multiply by 10^0, i.e. 1. 113 | ;;; 114 | ;;; In Airship Scheme, anything that starts in "+" or "-" followed by 115 | ;;; "inf." or "nan." is either a number or an error; it cannot be a 116 | ;;; symbol. These syntax errors reserve the infnan syntax for future 117 | ;;; extensions to the language without breaking existing code. 118 | ;;; 119 | ;;; Besides the addition of the literal infnan, the main difference 120 | ;;; here between Scheme and Common Lisp is the way complex numbers are 121 | ;;; written. In Common Lisp, a complex number is written in the style 122 | ;;; of "#C(2 3)", while the Scheme style is "2+3i". This makes the 123 | ;;; Scheme numeric syntax considerably more complicated. Scheme also 124 | ;;; supports polar notation, e.g. "-3@4". 125 | ;;; 126 | ;;; Also note that in CL, "4." becomes the integer "4" while in 127 | ;;; Scheme, "4." becomes the flonum "4.0". 128 | ;;; 129 | ;;; In a strict vanilla Scheme (as specified by the grammar in the 130 | ;;; R7RS-small appendix), writing the imaginary number 7i as "7i" is 131 | ;;; invalid; instead, it must be written as "+7i". However, there is 132 | ;;; no point to make that into invalid syntax in Airship Scheme 133 | ;;; because, unlike in CL, anything that starts with a number has to 134 | ;;; either be a number or invalid. That is, in Scheme, symbols 135 | ;;; starting with a number must be quoted with ||s, which means that 136 | ;;; "7i" can't be read as a symbol. It's actually more work to make 137 | ;;; "7i" an error instead of an imaginary number so it's easier to 138 | ;;; make yet another syntax extension to R7RS-small. Chibi Scheme, the 139 | ;;; first conforming R7RS-small implementation, also has this syntax 140 | ;;; extension. 141 | (define numbers 142 | (list 1 143 | +1 144 | -1 145 | 1.0 146 | 4. 147 | .4 148 | -.4 149 | +.4 150 | 1.0f0 151 | -1.2s3 152 | 1.0l-1 153 | 3d1 154 | 87e2 155 | 4/3 156 | 123/-456 157 | -3/2 158 | +inf.0 159 | -inf.0 160 | +nan.0 161 | -nan.0 162 | +inf.0f0 163 | -inf.0f0 164 | +nan.0f0 165 | -nan.0f0 166 | -4i 167 | +3i 168 | 7i 169 | 4-i 170 | 9+i 171 | +inf.0+inf.0i 172 | +inf.0-nan.0i 173 | +nan.0+inf.0i 174 | 4-inf.0i 175 | -12+nan.0f0i 176 | +inf.0-3i 177 | -nan.0+42i 178 | -nan.0f0-333i 179 | -nan.0f0+inf.0f0i 180 | +inf.0f0+22i 181 | +inf.0f0-nan.0f0i 182 | 333+nan.0f0i 183 | +inf.0i 184 | -inf.0f0i 185 | -nan.0i 186 | +nan.0d0i 187 | 4/3-3/4i 188 | 3e4-4e4i 189 | -4.0f30+3.0f20i 190 | -1+4i 191 | +4-3i 192 | 3+2i 193 | 4@5 194 | -3.0@+4e3 195 | -321.0f-3@+432f12 196 | 4@+inf.0 197 | -7@-nan.0 198 | +inf.0f0@111 199 | +inf.0@-3 200 | +nan.0@42 201 | +inf.0@-inf.0 202 | -nan.0@+nan.0 203 | +nan.0f0@-nan.0f0)) 204 | 205 | ;;;; TODO: The rest of the syntax will be demonstrated here, but this 206 | ;;;; file is currently incomplete. 207 | -------------------------------------------------------------------------------- /extra-procedures.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | ;;;; Extra procedures 6 | ;;;; 7 | ;;;; Procedures used by various SRFIs or core libraries, but not in 8 | ;;;; R7RS-small. 9 | 10 | ;;;; cl-environment 11 | 12 | (define-scheme-procedure (internal-time-units-per-second) 13 | internal-time-units-per-second) 14 | 15 | (define-scheme-procedure (internal-real-time) 16 | (get-internal-real-time)) 17 | 18 | (define-scheme-procedure (internal-run-time) 19 | (get-internal-run-time)) 20 | 21 | (define-scheme-procedure (lisp-implementation-type) 22 | (lisp-implementation-type)) 23 | 24 | (define-scheme-procedure (lisp-implementation-version) 25 | (lisp-implementation-version)) 26 | 27 | (define-scheme-procedure (user-homedir-pathname) 28 | (user-homedir-pathname)) 29 | 30 | ;;; SRFI 112 31 | 32 | (define-scheme-procedure (implementation-name) 33 | "Airship Scheme") 34 | 35 | (define-scheme-procedure (implementation-version) 36 | "0.0.0.0") 37 | 38 | (define-scheme-procedure (cpu-architecture) 39 | (machine-type)) 40 | 41 | (define-scheme-procedure (machine-name) 42 | (machine-instance)) 43 | 44 | (define-scheme-procedure (os-name) 45 | (software-type)) 46 | 47 | (define-scheme-procedure (os-version) 48 | (software-version)) 49 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (defpackage #:airship-scheme 4 | (:use #:cl 5 | #:zr-utils) 6 | ;; Uses a fast, implementation-specific version if available and 7 | ;; otherwise uses the slow, portable version 8 | (:export #:read-scheme) 9 | (:local-nicknames (:a :alexandria) 10 | (:f :float-features))) 11 | -------------------------------------------------------------------------------- /scheme-boolean.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | ;;;; A package for #t and #f 4 | ;;;; 5 | ;;;; Scheme distinguishes between #f and the empty list. This package 6 | ;;;; is used to give a unique package that contains the symbol that #f 7 | ;;;; will be read as in the Scheme reader, i.e. '%scheme-boolean:f 8 | ;;;; 9 | ;;;; There should be effectively no performance loss comparing to this 10 | ;;;; 'f instead of cl:nil. 11 | 12 | (defpackage #:%scheme-boolean 13 | (:use) 14 | (:import-from #:cl 15 | ;; Imported to avoid various problems 16 | #:defpackage 17 | #:function 18 | #:in-package 19 | #:nil 20 | #:quote 21 | ;; Actually used (reexported) 22 | #:t) 23 | (:export #:t #:f)) 24 | 25 | (defconstant %scheme-boolean:f '%scheme-boolean:f) 26 | -------------------------------------------------------------------------------- /scheme-core.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | (defpackage #:r7rs 6 | (:documentation "A package that the core R7RS symbols are read into.") 7 | (:use) 8 | ;; Imported to avoid various problems 9 | (:import-from #:cl 10 | #:defpackage 11 | #:function 12 | #:in-package 13 | #:nil 14 | #:quote)) 15 | 16 | (defpackage #:%scheme-thunk 17 | (:documentation "A package to namespace the internal Scheme thunk.") 18 | (:use) 19 | ;; Imported to avoid various problems 20 | (:import-from #:cl 21 | #:defpackage 22 | #:function 23 | #:in-package 24 | #:nil 25 | #:quote) 26 | (:export #:thunk)) 27 | 28 | (defun generate-lambda-list (list) 29 | "Generates a lambda list for `define-scheme-procedure'" 30 | (typecase list 31 | (cons (loop :for sublist :on list 32 | :by (lambda (x) 33 | (let ((rest (rest x))) 34 | (if (not (listp rest)) 35 | `(&rest ,rest) 36 | rest))) 37 | :collect (car sublist))) 38 | (null nil) 39 | (t `(&rest ,list)))) 40 | 41 | ;;; TODO: The external-to-CL versions of these procedures should call 42 | ;;; the function within the trampoline with #'values as the 43 | ;;; continuation. 44 | (defmacro %define-scheme-procedure ((name continuation &rest scheme-lambda-list) &body body) 45 | " 46 | Defines a Scheme procedure with a Common Lisp body and an explicit 47 | continuation. 48 | " 49 | `(define-function ,(intern (symbol-name name) '#:r7rs) 50 | ,(list* `(,continuation function) (generate-lambda-list scheme-lambda-list)) 51 | (multiple-value-call ,continuation (progn ,@body)))) 52 | 53 | ;;; TODO: Explicit continuation in the call to %define 54 | (defmacro define-scheme-procedure ((name &rest scheme-lambda-list) &body body) 55 | "Defines a Scheme procedure based on a Common Lisp body." 56 | `(%define-scheme-procedure (,name ,(gensym #.(symbol-name '#:k)) ,@scheme-lambda-list) 57 | ,@body)) 58 | 59 | (defmacro define-scheme-predicate ((name &rest scheme-lambda-list) &body body) 60 | " 61 | Defines a Scheme procedure based on a Common Lisp body, while also 62 | converting a NIL return value to #f 63 | " 64 | `(define-scheme-procedure (,name ,@scheme-lambda-list) 65 | (nil-to-false (progn ,@body)))) 66 | 67 | (defmacro define-scheme-cxr ((variable pair)) 68 | " 69 | Defines a CXR procedure (e.g. CAR) with Scheme's slightly different 70 | rules for input. 71 | " 72 | `(define-scheme-procedure (,variable ,pair) 73 | (if (null ,pair) 74 | (error "Attempted to use a cxr operation on an empty list") 75 | (,variable ,pair)))) 76 | 77 | ;;; TODO: This is temporary. When Scheme library support is added, the 78 | ;;; libraries would actually generate something almost like this, but 79 | ;;; only for the symbols that are specified in the library definition, 80 | ;;; with potential renaming as a possibility. 81 | (defmacro with-r7rs-global-environment (&body body) 82 | " 83 | Puts every R7RS procedure into one big LET to achieve Lisp-1 behavior 84 | from within the host Lisp-2. This means that FUNCALL (or 85 | MULTIPLE-VALUE-CALL) is always required internally within the Scheme 86 | when calling procedures. That is, procedures and variables now share 87 | the same namespace, which is 'global' because this is the parent 88 | environment to all Scheme-defined procedures. 89 | 90 | e.g. Scheme's (foo 42) is really (funcall foo continuation 42) 91 | 92 | Direct usage of this macro would look like this: 93 | 94 | (with-r7rs-global-environment 95 | (funcall r7rs::odd? #'identity 1)) 96 | 97 | Written in Scheme, it would look like this: 98 | 99 | (odd? 1) 100 | 101 | And the return value would be printed as T if the result is printed as 102 | Common Lisp or #t if the result is printed as Scheme. 103 | " 104 | (let* ((standard-procedures (let ((l (list))) 105 | (do-symbols (s :r7rs l) 106 | (push s l)))) 107 | (procedure-variables (mapcar (lambda (s) 108 | `(,s (function ,s))) 109 | standard-procedures))) 110 | `(let ,procedure-variables 111 | (declare (ignorable ,@standard-procedures)) 112 | ,@body))) 113 | 114 | (eval-when (:compile-toplevel :load-toplevel :execute) 115 | (defun cps-transform-procedure (continuation identifier rest) 116 | (loop :with items := (reverse rest) 117 | :for item :in items 118 | :for gensym := (if (listp item) (gensym (symbol-name '#:k)) nil) 119 | :when gensym 120 | :collect (list gensym item) :into gensyms 121 | :collect (if gensym gensym item) :into args 122 | :finally 123 | ;; returns either a continuation or the top-level 124 | ;; continuation function call 125 | (return (loop :with k* := `(funcall ,identifier ,continuation ,@(reverse args)) 126 | :for (gensym item) :in gensyms 127 | :for k := (funcall (cps-transform* gensym item) (or k k*)) 128 | :finally (return (or k k*)))))) 129 | 130 | (defun cps-transform* (gensym expression) 131 | (let ((gensym (or gensym (gensym)))) 132 | (lambda (continuation) 133 | `(lambda (,gensym) 134 | ,(typecase expression 135 | ;; Note: Assumes the Scheme boolean, not the CL boolean. 136 | (null (error "Syntax Error: () is an empty procedure call.")) 137 | (list (destructuring-bind (identifier-or-expression &rest rest) expression 138 | (etypecase identifier-or-expression 139 | (list 140 | (let ((k (gensym (symbol-name '#:k)))) 141 | (funcall (cps-transform* k identifier-or-expression) 142 | (funcall (cps-transform* continuation (cons k rest)) gensym)))) 143 | (symbol 144 | (case identifier-or-expression 145 | ;; TODO: ensure that if hasn't been redefined 146 | ;; 147 | ;; TODO: Replace IF with a simplified transformation 148 | ;; 149 | ;; (r7rs::if 150 | ;; (destructuring-bind (test then &optional else) rest 151 | ;; (let* ((k (if (listp test) 152 | ;; (gensym (symbol-name '#:k)) 153 | ;; test)) 154 | ;; (then (cps-transform continuation then)) 155 | ;; (else (if else 156 | ;; (cps-transform continuation else) 157 | ;; ;; Note: unspecified 158 | ;; ''%scheme-boolean:f)) 159 | ;; ;; Note: uses the Scheme boolean 160 | ;; (continuation-branch `(if (eq ,k '%scheme-boolean:f) 161 | ;; ,else 162 | ;; ,then))) 163 | ;; (if (listp test) 164 | ;; (cps-transform `(lambda (,k) ,continuation-branch) test) 165 | ;; continuation-branch)))) 166 | (t (cps-transform-procedure continuation identifier-or-expression rest))))))) 167 | ;; (symbol expression) 168 | (t expression)))))) 169 | 170 | ;; TODO: remove the transformation when it's not necessary 171 | (defun cps-transform (expression) 172 | (let ((k (gensym (symbol-name '#:k)))) 173 | (funcall (cps-transform* k expression) k)))) 174 | 175 | ;;; example: 176 | ;;; (let ((x 2) (y 3)) 177 | ;;; (with-cps-transform #'identity (r7rs::+ (r7rs::* x x) y))) 178 | (defmacro with-cps-transform (expression) 179 | "Applies a continuation passing style transform to the expression." 180 | (cps-transform expression)) 181 | 182 | (define-function (thunk? :inline t) (object) 183 | "Determines if an object is a thunk." 184 | (and (listp object) 185 | (eq (car object) '%scheme-thunk:thunk))) 186 | 187 | (define-function (call-next :inline t) (thunk) 188 | "Calls the contents of a thunk." 189 | (funcall (cdr thunk))) 190 | 191 | (defun trampoline (object) 192 | " 193 | Iterates through tail-recursive functions that are wrapped in a thunk 194 | until it stops getting thunks. 195 | " 196 | (do ((item object (call-next item))) 197 | ((not (thunk? item)) item))) 198 | 199 | (defmacro thunk (object) 200 | "Creates a thunk." 201 | `(cons '%scheme-thunk:thunk 202 | (lambda () ,object))) 203 | -------------------------------------------------------------------------------- /scheme-string.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | ;;;; Note: SBCL requires the use of SB-UNICODE for full Unicode 4 | ;;;; support for these various functions, but other Unicode-supporting 5 | ;;;; implementations just directly support full Unicode in the CL 6 | ;;;; package for things like upcasing. 7 | 8 | (in-package #:airship-scheme) 9 | 10 | (define-function (digit-value :inline t) (char) 11 | " 12 | Convert a digit character into the number it represents. For other 13 | characters, return NIL. 14 | " 15 | #+sbcl 16 | (sb-unicode:numeric-value char) 17 | #-sbcl 18 | (digit-char-p char)) 19 | 20 | (define-function (char-numeric-p :inline t) (char) 21 | "Test to see if a character is numeric." 22 | (and (digit-value char) t)) 23 | 24 | (define-function (char-alphabetic-p :inline t) (char) 25 | "Test to see if a character is alphabetic." 26 | #+sbcl 27 | (sb-unicode:alphabetic-p char) 28 | #-sbcl 29 | (alpha-char-p char)) 30 | 31 | ;;; Note: This might not be correct for all implementations, since as 32 | ;;; noted before, a CL implementation can support full Unicode without 33 | ;;; requiring calls to a Unicode library. Unfortunately, CL has no 34 | ;;; whitespace test built in. 35 | (define-function (char-whitespace-p :inline t) (char) 36 | "Test to see if a character represents whitespace." 37 | #+sbcl 38 | (and (sb-unicode:whitespace-p char) t) 39 | #-sbcl 40 | (or (char= char #\Newline) 41 | (char= char #\Space) 42 | (char= char #\Tab))) 43 | 44 | (define-function (char-upper-case-p :inline t) (letter) 45 | "Test to see if a character is upper case." 46 | #+sbcl 47 | (sb-unicode:uppercase-p letter) 48 | #-sbcl 49 | (upper-case-p letter)) 50 | 51 | (define-function (char-lower-case-p :inline t) (letter) 52 | "Test to see if a character is lower case." 53 | #+sbcl 54 | (sb-unicode:lowercase-p letter) 55 | #-sbcl 56 | (lower-case-p letter)) 57 | 58 | (define-function (char-upcase* :inline t) ((char character)) 59 | "Upcase a character by Unicode rules." 60 | #+sbcl 61 | (let ((s (make-string 1 :initial-element char))) 62 | (declare (dynamic-extent s)) 63 | (char (sb-unicode:uppercase s) 0)) 64 | #-sbcl 65 | (char-upcase char)) 66 | 67 | (define-function (char-downcase* :inline t) ((char character)) 68 | "Downcase a character by Unicode rules." 69 | #+sbcl 70 | (let ((s (make-string 1 :initial-element char))) 71 | (declare (dynamic-extent s)) 72 | (char (sb-unicode:lowercase s) 0)) 73 | #-sbcl 74 | (char-downcase char)) 75 | 76 | ;;; Note: This is another function which might not be correct for all 77 | ;;; implementations. 78 | (define-function (char-foldcase :inline t) ((char character)) 79 | "Foldcase a character by Unicode rules." 80 | #+sbcl 81 | (let ((s (make-string 1 :initial-element char))) 82 | (declare (dynamic-extent s)) 83 | (char (sb-unicode:casefold s) 0)) 84 | #-sbcl 85 | (char-downcase char)) 86 | 87 | (define-function (string-upcase* :inline t) (string) 88 | "Upcase a string by Unicode rules." 89 | #+sbcl 90 | (sb-unicode:uppercase string) 91 | #-sbcl 92 | (string-upcase string)) 93 | 94 | (define-function (string-downcase* :inline t) (string) 95 | "Downcase a string by Unicode rules." 96 | #+sbcl 97 | (sb-unicode:lowercase string) 98 | #-sbcl 99 | (string-downcase string)) 100 | 101 | ;;; Note: This might not be correct for all implementations. 102 | (define-function (string-foldcase :inline t) (string) 103 | "Foldcase a string by Unicode rules." 104 | #+sbcl 105 | (sb-unicode:casefold string) 106 | #-sbcl 107 | (string-downcase string)) 108 | 109 | (eval-when (:compile-toplevel :load-toplevel :execute) 110 | (define-function (compare :inline t) ((function function) (items list)) 111 | " 112 | Defines a short-circuiting predicate on an arbitrary-length list. 113 | " 114 | (when (endp items) 115 | (error "Expected at least one item")) 116 | (loop :for old-item := nil :then item 117 | :for item :in items 118 | :for match := t :then (funcall function old-item item) 119 | :always match)) 120 | #+sbcl 121 | (define-function (compare-foldcase :inline t) ((function function) (strings list)) 122 | " 123 | Defines a short-circuiting string predicate on an arbitrary-length 124 | list of strings, while doing a Unicode foldcase on each string. 125 | " 126 | (when (endp strings) 127 | (error "Expected at least one item")) 128 | (loop :for old-string := nil :then string* 129 | :for string :in strings 130 | :for string* := (string-foldcase string) 131 | :for match := t :then (funcall function old-string string*) 132 | :always match))) 133 | 134 | (defmacro define-string-predicate ((binary-name n-ary-name) binary-predicate &key foldcase) 135 | (let ((compare (if foldcase 'compare-foldcase 'compare))) 136 | `(progn 137 | (define-function (,binary-name :inline t) (string-1 string-2) 138 | (,binary-predicate string-1 string-2)) 139 | (define-compiler-macro ,n-ary-name (&whole whole &rest strings) 140 | (if strings 141 | (if (endp (cdr strings)) 142 | ;; TODO: optimize the one-arg version properly 143 | whole 144 | (if (endp (cddr strings)) 145 | (list ',binary-name (car strings) (cadr strings)) 146 | whole)) 147 | whole)) 148 | (define-function ,n-ary-name (&rest strings) 149 | (,compare (function ,binary-name) strings))))) 150 | 151 | (defmacro define-string-predicates (&body predicates) 152 | `(progn 153 | ,@(mapcar (lambda (definition) 154 | `(define-string-predicate ,@definition)) 155 | predicates))) 156 | 157 | #+sbcl 158 | (define-string-predicates 159 | ((%string=? string=?) sb-unicode:unicode=) 160 | ((%string-ci=? string-ci=?) sb-unicode:unicode-equal) 161 | ((%string? string>?) sb-unicode:unicode>) 164 | ((%string-ci>? string-ci>?) sb-unicode:unicode> :foldcase t) 165 | ((%string<=? string<=?) sb-unicode:unicode<=) 166 | ((%string-ci<=? string-ci<=?) sb-unicode:unicode<= :foldcase t) 167 | ((%string>=? string>=?) sb-unicode:unicode>=) 168 | ((%string-ci>=? string-ci>=?) sb-unicode:unicode>= :foldcase t)) 169 | 170 | #-sbcl 171 | (define-string-predicates 172 | ((%string=? string=?) string=) 173 | ((%string-ci=? string-ci=?) string-equal) 174 | ((%string? string>?) string>) 177 | ((%string-ci>? string-ci>?) string-greaterp) 178 | ((%string<=? string<=?) string<=) 179 | ((%string-ci<=? string-ci<=?) string-not-greaterp) 180 | ((%string>=? string>=?) string>=) 181 | ((%string-ci>=? string-ci>=?) string-not-lessp)) 182 | -------------------------------------------------------------------------------- /scheme-types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | ;;;; Helper functions useful for SATISFIES types or standalone tests 6 | 7 | (define-function (mathematical-integer-p :inline t) ((number number)) 8 | (zerop (nth-value 1 (round number)))) 9 | 10 | (define-function (%nanp :inline t) ((number number)) 11 | (and (floatp number) (f:float-nan-p number))) 12 | 13 | (defun nanp (number) 14 | "Tests if a number is NaN" 15 | (or (%nanp number) 16 | (and (complexp number) 17 | (or (%nanp (realpart number)) 18 | (%nanp (imagpart number)))))) 19 | 20 | (define-function (%infinitep :inline t) ((number number)) 21 | (and (floatp number) (f:float-infinity-p number))) 22 | 23 | (defun infinitep (number) 24 | "Tests if a number is an infinity" 25 | (or (%infinitep number) 26 | (and (complexp number) 27 | (or (%infinitep (realpart number)) 28 | (%infinitep (imagpart number)))))) 29 | 30 | (define-function (finitep :inline t) ((number number)) 31 | "Tests if a number is both not NaN and not an infinity" 32 | (not (or (infinitep number) (nanp number)))) 33 | 34 | ;;;; Type definition macros 35 | 36 | ;;;; TODO: The define-scheme-predicate could go here, too 37 | (defmacro %define-scheme-type ((name &rest lambda-list) predicate &body body) 38 | (let ((docstring (if (and (stringp (car body)) (cdr body)) 39 | (list (car body)) 40 | nil))) 41 | `(progn 42 | (deftype ,name ,lambda-list 43 | ,@body) 44 | (define-function (,name :inline t) (object) 45 | ,@docstring 46 | (and ,predicate t))))) 47 | 48 | ;;; For types with no built-in predicate 49 | (defmacro define-scheme-type ((name &rest lambda-list) &body body) 50 | `(%define-scheme-type (,name ,@lambda-list) (typep object ',name) 51 | ,@body)) 52 | 53 | ;;; For CL types that use a predicate instead of typep 54 | (defmacro define-scheme-type* ((name &rest lambda-list) predicate &body body) 55 | `(%define-scheme-type (,name ,@lambda-list) (,predicate object) 56 | ,@body)) 57 | 58 | ;;;; Numeric types 59 | 60 | (define-scheme-type* (number?) numberp 61 | 'number) 62 | 63 | (define-scheme-type* (complex?) numberp 64 | 'number) 65 | 66 | (define-scheme-type* (real?) realp 67 | 'real) 68 | 69 | (define-scheme-type (rational?) 70 | `(or rational float)) 71 | 72 | (define-scheme-type (integer?) 73 | " 74 | A Scheme integer? is a mathematical integer, which means that it is 75 | either a CL integer or it is a number (probably a float) that 76 | satisfies the mathematical definition of an integer. Since this is a 77 | SATISFIES type, it should be used sparingly. 78 | " 79 | `(or integer 80 | (and number (satisfies mathematical-integer-p)))) 81 | 82 | (define-scheme-type (exact?) 83 | "An exact number might be real or complex, but is not a float" 84 | `(or rational (complex rational))) 85 | 86 | (define-scheme-type (inexact?) 87 | "An inexact number is just a float, real or complex" 88 | `(or float (complex float))) 89 | 90 | (define-scheme-type (flonum?) 91 | 'double-float) 92 | 93 | (define-scheme-type (exact-integer?) 94 | "An exact integer is anything of the low-level CL integer type" 95 | 'integer) 96 | 97 | (define-scheme-type* (finite?) finitep 98 | "Any number that is neither an infinity nor a NaN" 99 | `(satisfies finitep)) 100 | 101 | (define-scheme-type* (infinite?) infinitep 102 | "Any floating point infinity" 103 | `(satisfies infinitep)) 104 | 105 | (define-scheme-type* (nan?) nanp 106 | "Any float that's a NaN" 107 | `(satisfies nanp)) 108 | 109 | (define-scheme-type* (zero?) zerop 110 | " 111 | A zero? is any way to represent zero, real or complex. A complex zero 112 | can exist if floating point. 113 | " 114 | `(or (real 0 0) 115 | (complex (float 0 0)))) 116 | 117 | ;;;; Other types 118 | 119 | (define-scheme-type (boolean?) 120 | " 121 | The two symbols that represent a Scheme Boolean, which externally are 122 | known as #t or #f 123 | " 124 | `(or (eql t) (eql %scheme-boolean:f))) 125 | 126 | (define-scheme-type (vector?) 127 | "A Scheme vector is just a T vector" 128 | 'simple-vector) 129 | 130 | (define-scheme-type (string?) 131 | "A Scheme string is just a simple string." 132 | 'simple-string) 133 | 134 | (define-scheme-type (char?) 135 | "A Scheme char is just a character." 136 | 'character) 137 | 138 | (define-scheme-type (bytevector?) 139 | "A Scheme bytevector is just an octet vector" 140 | `(simple-array octet (*))) 141 | 142 | (define-scheme-type (symbol?) 143 | "Tests if an object is a Scheme symbol" 144 | `(and symbol (not null) (not boolean?))) 145 | 146 | (define-scheme-type* (list?) a:proper-list-p 147 | "Scheme's list? tests for a proper list" 148 | 'a:proper-list) 149 | 150 | (define-scheme-type* (%list?) listp 151 | " 152 | A lower-level, faster list test that permits improper lists, which 153 | don't end in NIL. 154 | " 155 | 'list) 156 | 157 | (define-scheme-type* (pair?) consp 158 | "A pair? in Scheme is a cons cell." 159 | 'cons) 160 | 161 | (define-scheme-type* (null?) null 162 | "A null? in Scheme is nil." 163 | 'null) 164 | 165 | (define-scheme-type* (port?) streamp 166 | 'stream) 167 | 168 | (define-scheme-type* (input-port?) input-stream-p 169 | `(satisfies input-stream-p)) 170 | 171 | (define-scheme-type* (output-port?) output-stream-p 172 | `(satisfies output-stream-p)) 173 | 174 | ;;;; Type creation 175 | 176 | ;;; TODO: handle short/long float in Lisps that have them (s0, l0) 177 | (defun sign-bit? (float) 178 | " 179 | Determines if the sign bit is 1 or not, which is used in the creation 180 | of NaNs. 181 | " 182 | (etypecase float 183 | (single-float (logbitp (- (expt 2 5) 1) (f:single-float-bits float))) 184 | (double-float (logbitp (- (expt 2 6) 1) (f:double-float-bits float))))) 185 | 186 | (defun nan (float-type &optional negate?) 187 | " 188 | If possible, this creates a NaN with the given sign and of the given 189 | type of float. 190 | 191 | This is used for literal NaNs in the Scheme reader. 192 | " 193 | (and float-type 194 | (let* ((zero (coerce 0 float-type)) 195 | (nan (f:with-float-traps-masked t (/ zero zero))) 196 | (-nan? (sign-bit? nan))) 197 | (if negate? 198 | (if -nan? nan (- nan)) 199 | (if -nan? (- nan) nan))))) 200 | 201 | (define-function (inf :inline t) (float-type &optional negate?) 202 | " 203 | If possible, this creates a positive or negative infinity of the given 204 | type of float. 205 | 206 | This is used for literal infinities in the Scheme reader. 207 | " 208 | (declare (optimize (speed 3))) 209 | ;; Tell SBCL not to warn us about unreachable branches being deleted 210 | ;; because that's kind of the point of inlining this function. 211 | (locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 212 | (case float-type 213 | (double-float 214 | (if negate? 215 | f:double-float-negative-infinity 216 | f:double-float-positive-infinity)) 217 | (single-float 218 | (if negate? 219 | f:single-float-negative-infinity 220 | f:single-float-positive-infinity)) 221 | (long-float 222 | (if negate? 223 | f:long-float-negative-infinity 224 | f:long-float-positive-infinity)) 225 | (short-float 226 | (if negate? 227 | f:short-float-negative-infinity 228 | f:short-float-positive-infinity)) 229 | (t nil)))) 230 | 231 | ;;;; Type Conversion 232 | 233 | (define-function (inexact :inline t) ((z number)) 234 | "Converts a number to a Scheme inexact." 235 | (etypecase z 236 | ((and complex exact?) (coerce z '(complex double-float))) 237 | (exact? (coerce z 'double-float)) 238 | (number z))) 239 | 240 | ;;; Note: This uses rationalize. cl:rationalize is not the same thing 241 | ;;; as Scheme's rationalize. Racket's inexact->exact behaves more like 242 | ;;; cl:rational instead, but rationalize produces less surprising 243 | ;;; fractions. 244 | (define-function (exact :inline t) ((z number)) 245 | "Converts a number to a Scheme exact." 246 | (etypecase z 247 | ((and complex inexact?) (complex (rationalize (realpart z)) 248 | (rationalize (imagpart z)))) 249 | (inexact? (rationalize z)) 250 | (number z))) 251 | -------------------------------------------------------------------------------- /scheme-write.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | ;;; Note: ignores short-float and long-float in SBCL to avoid having 6 | ;;; an unreachable code note. 7 | (defun write-flonum-suffix (number stream) 8 | " 9 | Writes the suffix of a special flonum. This assumes that a double 10 | float is the default, writing no suffix. 11 | " 12 | (etypecase number 13 | (double-float 14 | nil) 15 | (single-float 16 | (write-string "f0" stream) 17 | nil) 18 | #-sbcl 19 | (short-float 20 | (write-string "s0" stream) 21 | nil) 22 | #-sbcl 23 | (long-float 24 | (write-string "l0" stream) 25 | nil))) 26 | 27 | (defun write-scheme-number (number &optional (stream *standard-output*) (*print-base* 10)) 28 | "Writes a number in the way that Scheme reads numbers." 29 | (let ((stream (if (eq stream t) *standard-output* stream))) 30 | (etypecase number 31 | (rational 32 | (if (> *print-base* 10) 33 | (format stream "~A" (string-downcase (format nil "~A" number))) 34 | (format stream "~A" number))) 35 | (float (let ((*read-default-float-format* 'double-float)) 36 | (cond ((infinitep number) 37 | (format stream "~:[-~;+~]inf.0" (plusp number)) 38 | (write-flonum-suffix number stream)) 39 | ((nanp number) 40 | (format stream "~:[+~;-~]nan.0" (sign-bit? number)) 41 | (write-flonum-suffix number stream)) 42 | (t 43 | (format stream "~A" number))))) 44 | (complex 45 | (write-scheme-number (realpart number) stream *print-base*) 46 | (when (and (finitep (imagpart number)) (plusp (imagpart number))) 47 | (write-char #\+ stream)) 48 | (let ((imagpart (imagpart number))) 49 | (cond ((not (finitep imagpart)) 50 | (write-scheme-number imagpart stream *print-base*)) 51 | ((= imagpart -1) 52 | (write-char #\- stream)) 53 | ((not (= imagpart 1)) 54 | (write-scheme-number imagpart stream *print-base*)))) 55 | (write-char #\i stream)))) 56 | nil) 57 | 58 | ;;; TODO: write-scheme 59 | -------------------------------------------------------------------------------- /scheme/base.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme base) 4 | (import (airship r7rs)) 5 | (export * + - ... / < <= = => > >= _ abs and append apply assoc assq assv 6 | begin binary-port? boolean=? boolean? bytevector bytevector-append 7 | bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref 8 | bytevector-u8-set! bytevector? caar cadr 9 | call-with-current-continuation call-with-port call-with-values call/cc 10 | car case cdar cddr cdr ceiling char->integer char-ready? char<=? 11 | char=? char>? char? close-input-port close-output-port 12 | close-port complex? cond cond-expand cons current-error-port 13 | current-input-port current-output-port define define-record-type 14 | define-syntax define-values denominator do dynamic-wind else 15 | eof-object eof-object? eq? equal? eqv? error error-object-irritants 16 | error-object-message error-object? even? exact exact-integer-sqrt 17 | exact-integer? exact? expt features file-error? floor floor-quotient 18 | floor-remainder floor/ flush-output-port for-each gcd 19 | get-output-bytevector get-output-string guard if include include-ci 20 | inexact inexact? input-port-open? input-port? integer->char integer? 21 | lambda lcm length let let* let*-values let-syntax let-values 22 | letrec letrec* letrec-syntax list list->string list->vector list-copy 23 | list-ref list-set! list-tail list? make-bytevector make-list 24 | make-parameter make-string make-vector map max member memq memv min 25 | modulo negative? newline not null? number->string number? numerator 26 | odd? open-input-bytevector open-input-string open-output-bytevector 27 | open-output-string or output-port-open? output-port? pair? 28 | parameterize peek-char peek-u8 port? positive? procedure? quasiquote 29 | quote quotient raise raise-continuable rational? rationalize 30 | read-bytevector read-bytevector! read-char read-error? read-line 31 | read-string read-u8 real? remainder reverse round set! set-car! 32 | set-cdr! square string string->list string->number string->symbol 33 | string->utf8 string->vector string-append string-copy string-copy! 34 | string-fill! string-for-each string-length string-map string-ref 35 | string-set! string<=? string=? string>? string? 36 | substring symbol->string symbol=? symbol? syntax-error syntax-rules 37 | textual-port? truncate truncate-quotient truncate-remainder truncate/ 38 | u8-ready? unless unquote unquote-splicing utf8->string values vector 39 | vector->list vector->string vector-append vector-copy vector-copy! 40 | vector-fill! vector-for-each vector-length vector-map vector-ref 41 | vector-set! vector? when with-exception-handler write-bytevector 42 | write-char write-string write-u8 zero?)) 43 | -------------------------------------------------------------------------------- /scheme/case-lambda.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme case-lambda) 4 | (import (airship r7rs)) 5 | (export case-lambda)) 6 | -------------------------------------------------------------------------------- /scheme/char.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme char) 4 | (import (airship r7rs)) 5 | (export char-alphabetic? char-ci<=? char-ci=? char-ci>? 6 | char-downcase char-foldcase char-lower-case? char-numeric? char-upcase 7 | char-upper-case? char-whitespace? digit-value string-ci<=? string-ci=? string-ci>? string-downcase string-foldcase 9 | string-upcase)) 10 | -------------------------------------------------------------------------------- /scheme/complex.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme complex) 4 | (import (airship r7rs)) 5 | (export angle imag-part magnitude make-polar make-rectangular real-part)) 6 | -------------------------------------------------------------------------------- /scheme/cxr.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme cxr) 4 | (import (airship r7rs)) 5 | (export caaaar caaadr caaar caadar caaddr caadr cadaar cadadr cadar caddar 6 | cadddr caddr cdaaar cdaadr cdaar cdadar cdaddr cdadr cddaar cddadr 7 | cddar cdddar cddddr cdddr)) 8 | -------------------------------------------------------------------------------- /scheme/eval.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme eval) 4 | (import (airship r7rs)) 5 | (export environment eval)) 6 | -------------------------------------------------------------------------------- /scheme/file.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme file) 4 | (import (airship r7rs)) 5 | (export call-with-input-file call-with-output-file delete-file file-exists? 6 | open-binary-input-file open-binary-output-file open-input-file 7 | open-output-file with-input-from-file with-output-to-file)) 8 | -------------------------------------------------------------------------------- /scheme/inexact.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme inexact) 4 | (import (airship r7rs)) 5 | (export (acos asin atan cos exp finite? infinite? log nan? sin sqrt tan))) 6 | -------------------------------------------------------------------------------- /scheme/lazy.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme lazy) 4 | (import (airship r7rs)) 5 | (export delay delay-force force make-promise promise?)) 6 | -------------------------------------------------------------------------------- /scheme/load.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme load) 4 | (import (airship r7rs)) 5 | (export load)) 6 | -------------------------------------------------------------------------------- /scheme/process-context.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme process-context) 4 | (import (airship r7rs)) 5 | (export command-line emergency-exit exit get-environment-variable 6 | get-environment-variables)) 7 | -------------------------------------------------------------------------------- /scheme/r5rs.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme r5rs) 4 | (import (airship r7rs)) 5 | (export * + - / < <= = > >= abs acos and angle append apply asin assoc assq 6 | assv atan begin boolean? caaaar caaadr caaar caadar caaddr caadr caar 7 | cadaar cadadr cadar caddar cadddr caddr cadr 8 | call-with-current-continuation call-with-input-file 9 | call-with-output-file call-with-values car case cdaaar cdaadr cdaar 10 | cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr 11 | cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? 13 | char-numeric? char-ready? char-upcase char-upper-case? 14 | char-whitespace? char<=? char=? char>? char? 15 | close-input-port close-output-port complex? cond cons cos 16 | current-input-port current-output-port define define-syntax delay 17 | denominator display do dynamic-wind eof-object? eq? equal? eqv? eval 18 | even? exact->inexact exact? exp expt floor for-each force gcd if 19 | imag-part inexact->exact inexact? input-port? integer->char integer? 20 | interaction-environment lambda lcm length let let* let-syntax letrec 21 | letrec-syntax list list->string list->vector list-ref list-tail list? 22 | load log magnitude make-polar make-rectangular make-string make-vector 23 | map max member memq memv min modulo negative? newline not 24 | null-environment null? number->string number? numerator odd? 25 | open-input-file open-output-file or output-port? pair? peek-char 26 | positive? procedure? quasiquote quote quotient rational? rationalize 27 | read read-char real-part real? remainder reverse round 28 | scheme-report-environment set! set-car! set-cdr! sin sqrt string 29 | string->list string->number string->symbol string-append string-ci<=? 30 | string-ci=? string-ci>? string-copy 31 | string-fill! string-length string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol? 33 | tan truncate values vector vector->list vector-fill! vector-length 34 | vector-ref vector-set! vector? with-input-from-file 35 | with-output-to-file write write-char zero?)) 36 | -------------------------------------------------------------------------------- /scheme/read.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme read) 4 | (import (airship r7rs)) 5 | (export read)) 6 | -------------------------------------------------------------------------------- /scheme/repl.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme repl) 4 | (import (airship r7rs)) 5 | (export interaction-environment)) 6 | -------------------------------------------------------------------------------- /scheme/time.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme time) 4 | (import (airship r7rs)) 5 | (export current-jiffy current-second jiffies-per-second)) 6 | -------------------------------------------------------------------------------- /scheme/write.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (scheme write) 4 | (import (airship r7rs)) 5 | (export display write write-shared write-simple)) 6 | -------------------------------------------------------------------------------- /srfi/112.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 112) 4 | ;; TODO: probably not the final name 5 | (import (airship extras)) 6 | (export cpu-architecture 7 | implementation-name 8 | implementation-version 9 | machine-name 10 | os-name 11 | os-version)) 12 | -------------------------------------------------------------------------------- /srfi/172.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 172) 4 | (import (scheme base)) 5 | (import (scheme case-lambda)) 6 | (import (scheme char)) 7 | (import (scheme complex)) 8 | (import (scheme cxr)) 9 | (import (scheme inexact)) 10 | (import (scheme lazy)) 11 | (export - * / + < <= = => > >= abs acos and angle append apply asin assoc assq 12 | assv atan begin boolean? boolean=? bytevector bytevector? 13 | bytevector-append bytevector-copy bytevector-copy! bytevector-length 14 | bytevector-u8-ref bytevector-u8-set! caaaar caaadr caaar caadar caaddr 15 | caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc 16 | call-with-current-continuation call-with-port call-with-values car 17 | case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar 18 | cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char? char? char>=? char->integer char-alphabetic? char-ci? char-ci>=? char-downcase char-foldcase 21 | char-lower-case? char-numeric? char-upcase char-upper-case? 22 | char-whitespace? close-input-port close-output-port close-port 23 | complex? cond cond-expand cons cos delay delay-force denominator 24 | digit-value do dynamic-wind else eof-object eof-object? eq? equal? 25 | eqv? error error-object? error-object-irritants error-object-message 26 | even? exact exact? exact-integer? exact-integer-sqrt exp expt finite? 27 | floor floor/ floor-quotient floor-remainder force for-each gcd 28 | get-output-bytevector get-output-string guard if imag-part inexact 29 | inexact? infinite? input-port? integer? integer->char lambda lcm 30 | length let let* let*-values letrec letrec* let-values list list? 31 | list->string list->vector list-copy list-ref list-set! list-tail log 32 | magnitude make-bytevector make-list make-parameter make-polar 33 | make-promise make-rectangular make-string make-vector map max member 34 | memq memv min modulo nan? negative? newline not null? number? 35 | number->string numerator odd? open-input-bytevector open-input-string 36 | open-output-bytevector open-output-string or output-port? pair? 37 | peek-char peek-u8 parameterize port? positive? procedure? promise? 38 | quasiquote quote quotient raise raise-continuable rational? 39 | rationalize read-bytevector read-bytevector! read-char read-error? 40 | read-line read-string read-u8 real? real-part remainder reverse round 41 | set! set-car! set-cdr! sin sqrt square string string? string? string>=? string->list string->number 43 | string->utf8 string->vector string-append string-ci? string-ci>=? string-copy string-copy! 45 | string-downcase string-fill! string-foldcase string-for-each 46 | string-length string-map string-ref string-set! string-upcase 47 | substring symbol? symbol=? symbol->string tan textual-port? truncate 48 | truncate/ truncate-quotient truncate-remainder unless unquote 49 | unquote-splicing utf8->string values vector vector? vector->list 50 | vector->string vector-append vector-copy vector-copy! vector-fill! 51 | vector-for-each vector-length vector-map vector-ref vector-set! when 52 | with-exception-handler write-bytevector write-char write-string 53 | write-u8 zero?)) 54 | -------------------------------------------------------------------------------- /srfi/172/functional.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | ;;; Note: A functional library can only use things that are 4 | ;;; functional, i.e. things that have no side effects. Use of things 5 | ;;; that are not functional is an error. 6 | ;;; 7 | ;;; SRFI 172 functional serves as a base for other functional 8 | ;;; libraries by preventing the import of things that would be an 9 | ;;; error to use. 10 | (define-library (srfi 172 functional) 11 | (functional) 12 | (import (airship functional)) 13 | (export - * / + < <= = => > >= abs acos and angle append apply asin assoc assq 14 | assv atan begin boolean? boolean=? bytevector bytevector? 15 | bytevector-append bytevector-copy bytevector-length bytevector-u8-ref 16 | caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar 17 | caddar cadddr caddr cadr call/cc call-with-current-continuation 18 | call-with-values car case case-lambda cdaaar cdaadr cdaar cdadar 19 | cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr 20 | ceiling char? char? char>=? char->integer 21 | char-alphabetic? char-ci? char-ci>=? 22 | char-downcase char-foldcase char-lower-case? char-numeric? char-upcase 23 | char-upper-case? char-whitespace? complex? cond cond-expand cons cos 24 | delay delay-force denominator digit-value do dynamic-wind else 25 | eof-object eof-object? eq? equal? eqv? error error-object? 26 | error-object-irritants error-object-message even? exact exact? 27 | exact-integer? exact-integer-sqrt exp expt finite? floor floor/ 28 | floor-quotient floor-remainder force for-each gcd 29 | get-output-bytevector get-output-string guard if imag-part inexact 30 | inexact? infinite? integer? integer->char lambda lcm length let let* 31 | let*-values letrec letrec* let-values list list? list->string 32 | list->vector list-copy list-ref list-tail log magnitude 33 | make-bytevector make-list make-parameter make-polar make-promise 34 | make-rectangular make-string make-vector map max member memq memv min 35 | modulo nan? negative? newline not null? number? number->string 36 | numerator odd? open-input-bytevector open-input-string 37 | open-output-bytevector open-output-string or pair? parameterize 38 | positive? procedure? promise? quasiquote quote quotient raise 39 | raise-continuable rational? rationalize real? real-part remainder 40 | reverse round sin sqrt square string string? string? string>=? string->list string->number string->utf8 42 | string->vector string-append string-ci? string-ci>=? string-copy string-downcase string-foldcase 44 | string-for-each string-length string-map string-ref string-upcase 45 | substring symbol? symbol=? symbol->string tan truncate truncate/ 46 | truncate-quotient truncate-remainder unless unquote unquote-splicing 47 | utf8->string values vector vector? vector->list vector->string 48 | vector-append vector-copy vector-for-each vector-length vector-map 49 | vector-ref when with-exception-handler zero?)) 50 | -------------------------------------------------------------------------------- /srfi/6.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 6) 4 | (functional) 5 | (import (srfi 172 functional)) 6 | (export get-output-string 7 | open-input-string 8 | open-output-string)) 9 | -------------------------------------------------------------------------------- /srfi/87.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 87) 4 | (functional) 5 | (import (srfi 172 functional)) 6 | (export case)) 7 | -------------------------------------------------------------------------------- /srfi/9.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 9) 4 | (import (scheme base)) 5 | (export define-record-type)) 6 | -------------------------------------------------------------------------------- /srfi/98.sld: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: scheme; -*- 2 | 3 | (define-library (srfi 98) 4 | (import (scheme process-context)) 5 | (export get-environment-variable 6 | get-environment-variables)) 7 | -------------------------------------------------------------------------------- /standard-procedures.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | ;;;; Standard procedures 6 | ;;;; 7 | ;;;; These are the standard procedures built into r7rs-small Scheme, 8 | ;;;; as described in chapter 6 of Revised^7 Report on the Algorithmic 9 | ;;;; Language Scheme, as found in r7rs.pdf. These are implemented in 10 | ;;;; Common Lisp macros, intended to be called from within the Scheme 11 | ;;;; runtime. 12 | ;;;; 13 | ;;;; Don't compose Scheme procedures here. This file is for the 14 | ;;;; built-in standard procedures that are implemented directly 15 | ;;;; through Common Lisp. It's possible that some of these might be 16 | ;;;; moved to a Scheme file if they are best implemented directly in 17 | ;;;; Scheme. 18 | ;;;; 19 | ;;;; Try to keep these as simple as possible. If a lot of complexity 20 | ;;;; is needed, consider writing a helper CL function that implements 21 | ;;;; the Scheme semantics. This will make things easier to test. 22 | 23 | ;;;; todo: add type checks where type checks are needed 24 | ;;;; todo: add errors when errors are required 25 | 26 | ;;;; 6.1 - Equivalence predicates 27 | 28 | (define-scheme-predicate (eqv? obj1 obj2) 29 | (eqv? obj1 obj2)) 30 | 31 | (define-scheme-predicate (eq? obj1 obj2) 32 | (eq obj1 obj2)) 33 | 34 | (define-scheme-predicate (equal? obj1 obj2) 35 | (equal? obj1 obj2)) 36 | 37 | ;;;; 6.2 - Numbers 38 | 39 | ;;; Numerical predicates 40 | 41 | (define-scheme-predicate (number? obj) 42 | (number? obj)) 43 | 44 | (define-scheme-predicate (complex? obj) 45 | (complex? obj)) 46 | 47 | (define-scheme-predicate (real? obj) 48 | (real? obj)) 49 | 50 | (define-scheme-predicate (rational? obj) 51 | (rational? obj)) 52 | 53 | (define-scheme-predicate (integer? obj) 54 | (integer? obj)) 55 | 56 | (define-scheme-predicate (exact? z) 57 | (exact? z)) 58 | 59 | (define-scheme-predicate (inexact? z) 60 | (inexact? z)) 61 | 62 | (define-scheme-predicate (exact-integer? z) 63 | (exact-integer? z)) 64 | 65 | (define-scheme-predicate (finite? z) 66 | (finite? z)) 67 | 68 | (define-scheme-predicate (infinite? z) 69 | (infinite? z)) 70 | 71 | (define-scheme-predicate (nan? z) 72 | (nan? z)) 73 | 74 | ;;; Basic numerical procedures 75 | 76 | (define-scheme-predicate (= z . more-numbers) 77 | (apply #'= z more-numbers)) 78 | 79 | (define-scheme-predicate (< x . more-numbers) 80 | (apply #'< x more-numbers)) 81 | 82 | (define-scheme-predicate (> x . more-numbers) 83 | (apply #'> x more-numbers)) 84 | 85 | (define-scheme-predicate (<= x . more-numbers) 86 | (apply #'<= x more-numbers)) 87 | 88 | (define-scheme-predicate (>= x . more-numbers) 89 | (apply #'>= x more-numbers)) 90 | 91 | (define-scheme-predicate (zero? z) 92 | (zero? z)) 93 | 94 | (define-scheme-predicate (positive? x) 95 | (plusp x)) 96 | 97 | (define-scheme-predicate (negative? x) 98 | (minusp x)) 99 | 100 | (define-scheme-predicate (odd? n) 101 | (oddp n)) 102 | 103 | (define-scheme-predicate (even? n) 104 | (evenp n)) 105 | 106 | (define-scheme-procedure (max x . more-numbers) 107 | (apply #'max x more-numbers)) 108 | 109 | (define-scheme-procedure (min x . more-numbers) 110 | (apply #'min x more-numbers)) 111 | 112 | (define-scheme-procedure (+ . numbers) 113 | (apply #'+ numbers)) 114 | 115 | (define-scheme-procedure (* . numbers) 116 | (apply #'* numbers)) 117 | 118 | (define-scheme-procedure (- z . more-numbers) 119 | (apply #'- z more-numbers)) 120 | 121 | (define-scheme-procedure (/ z . more-numbers) 122 | (apply #'/ z more-numbers)) 123 | 124 | (define-scheme-procedure (abs x) 125 | (abs x)) 126 | 127 | ;;; More numerical procedures 128 | 129 | (define-scheme-procedure (floor/ n1 n2) 130 | (floor n1 n2)) 131 | 132 | (define-scheme-procedure (floor-quotient n1 n2) 133 | (values (floor n1 n2))) 134 | 135 | (define-scheme-procedure (floor-remainder n1 n2) 136 | (mod n1 n2)) 137 | 138 | (define-scheme-procedure (truncate/ n1 n2) 139 | (truncate n1 n2)) 140 | 141 | (define-scheme-procedure (truncate-quotient n1 n2) 142 | (values (truncate n1 n2))) 143 | 144 | (define-scheme-procedure (truncate-remainder n1 n2) 145 | (rem n1 n2)) 146 | 147 | (define-scheme-procedure (quotient n1 n2) 148 | (values (truncate n1 n2))) 149 | 150 | (define-scheme-procedure (remainder n1 n2) 151 | (rem n1 n2)) 152 | 153 | (define-scheme-procedure (modulo n1 n2) 154 | (mod n1 n2)) 155 | 156 | (define-scheme-procedure (gcd . integers) 157 | (apply #'gcd integers)) 158 | 159 | (define-scheme-procedure (lcm . integers) 160 | (apply #'lcm integers)) 161 | 162 | (define-scheme-procedure (numerator q) 163 | (numerator q)) 164 | 165 | (define-scheme-procedure (denominator q) 166 | (denominator q)) 167 | 168 | (define-scheme-procedure (floor x) 169 | (values (floor x))) 170 | 171 | (define-scheme-procedure (ceiling x) 172 | (values (ceiling x))) 173 | 174 | (define-scheme-procedure (truncate x) 175 | (values (truncate x))) 176 | 177 | (define-scheme-procedure (round x) 178 | (values (round x))) 179 | 180 | ;;; (rationalize x y) 181 | 182 | (define-scheme-procedure (exp z) 183 | (exp z)) 184 | 185 | (define-scheme-procedure (log z &optional base) 186 | (if base 187 | (log z base) 188 | (log z))) 189 | 190 | (define-scheme-procedure (sin z) 191 | (sin z)) 192 | 193 | (define-scheme-procedure (cos z) 194 | (cos z)) 195 | 196 | (define-scheme-procedure (tan z) 197 | (tan z)) 198 | 199 | (define-scheme-procedure (asin z) 200 | (asin z)) 201 | 202 | (define-scheme-procedure (acos z) 203 | (acos z)) 204 | 205 | (define-scheme-procedure (atan y &optional x) 206 | (if x 207 | (atan y x) 208 | (atan y))) 209 | 210 | (define-scheme-procedure (square x) 211 | (expt x 2)) 212 | 213 | (define-scheme-procedure (sqrt x) 214 | (sqrt x)) 215 | 216 | ;;; Note: Call with #'values, not with #'identity. 217 | (define-scheme-procedure (exact-integer-sqrt k) 218 | (let* ((s (isqrt k)) 219 | (r (- k (expt s 2)))) 220 | (values s r))) 221 | 222 | (define-scheme-procedure (expt x1 x2) 223 | (expt x1 x2)) 224 | 225 | (define-scheme-procedure (make-rectangular x1 x2) 226 | (complex x1 x2)) 227 | 228 | (define-scheme-procedure (make-polar x1 x2) 229 | (* x1 (cis x2))) 230 | 231 | (define-scheme-procedure (real-part z) 232 | (realpart z)) 233 | 234 | (define-scheme-procedure (imag-part z) 235 | (imagpart z)) 236 | 237 | (define-scheme-procedure (magnitude z) 238 | (abs z)) 239 | 240 | (define-scheme-procedure (angle z) 241 | (phase z)) 242 | 243 | (define-scheme-procedure (inexact z) 244 | (inexact z)) 245 | 246 | (define-scheme-procedure (exact z) 247 | (exact z)) 248 | 249 | ;;; R5RS 250 | 251 | (define-scheme-procedure (exact->inexact z) 252 | (inexact z)) 253 | 254 | (define-scheme-procedure (inexact->exact z) 255 | (exact z)) 256 | 257 | ;;; Input and output 258 | 259 | (define-scheme-procedure (number->string z &optional (radix 10)) 260 | (with-output-to-string (out) 261 | (write-scheme-number z out radix))) 262 | 263 | (define-scheme-predicate (string->number string &optional (radix 10)) 264 | (string-to-number string radix)) 265 | 266 | ;;;; 6.3 - Booleans 267 | 268 | (define-scheme-predicate (not obj) 269 | (eq obj '%scheme-boolean:f)) 270 | 271 | (define-scheme-predicate (boolean? obj) 272 | (boolean? obj)) 273 | 274 | (define-scheme-predicate (boolean=? . booleans) 275 | (cond ((null booleans) t) 276 | ((eq (car booleans) t) 277 | (every (lambda (x) (eq x t)) booleans)) 278 | ((eq (car booleans) '%scheme-boolean:f) 279 | (every (lambda (x) (eq x '%scheme-boolean:f)) booleans)) 280 | (t '%scheme-boolean:f))) 281 | 282 | ;;;; 6.4 - Pairs and lists 283 | 284 | ;;; Basic cons pair procedures 285 | 286 | (define-scheme-predicate (pair? obj) 287 | (pair? obj)) 288 | 289 | (define-scheme-procedure (cons obj1 obj2) 290 | (cons obj1 obj2)) 291 | 292 | (define-scheme-procedure (set-car! pair obj) 293 | (setf (car pair) obj)) 294 | 295 | (define-scheme-procedure (set-cdr! pair obj) 296 | (setf (cdr pair) obj)) 297 | 298 | ;;; main library cxr procedures 299 | 300 | (define-scheme-cxr (car pair)) 301 | (define-scheme-cxr (cdr pair)) 302 | (define-scheme-cxr (caar pair)) 303 | (define-scheme-cxr (cadr pair)) 304 | (define-scheme-cxr (cdar pair)) 305 | (define-scheme-cxr (cddr pair)) 306 | 307 | ;;; cxr library procedures 308 | 309 | (define-scheme-cxr (caaaar pair)) 310 | (define-scheme-cxr (caaadr pair)) 311 | (define-scheme-cxr (caaar pair)) 312 | (define-scheme-cxr (caadar pair)) 313 | (define-scheme-cxr (caaddr pair)) 314 | (define-scheme-cxr (caadr pair)) 315 | (define-scheme-cxr (cadaar pair)) 316 | (define-scheme-cxr (cadadr pair)) 317 | (define-scheme-cxr (cadar pair)) 318 | (define-scheme-cxr (caddar pair)) 319 | (define-scheme-cxr (cadddr pair)) 320 | (define-scheme-cxr (caddr pair)) 321 | (define-scheme-cxr (cdaaar pair)) 322 | (define-scheme-cxr (cdaadr pair)) 323 | (define-scheme-cxr (cdaar pair)) 324 | (define-scheme-cxr (cdadar pair)) 325 | (define-scheme-cxr (cdaddr pair)) 326 | (define-scheme-cxr (cdadr pair)) 327 | (define-scheme-cxr (cddaar pair)) 328 | (define-scheme-cxr (cddadr pair)) 329 | (define-scheme-cxr (cddar pair)) 330 | (define-scheme-cxr (cdddar pair)) 331 | (define-scheme-cxr (cddddr pair)) 332 | (define-scheme-cxr (cdddr pair)) 333 | 334 | ;;; List procedures 335 | 336 | (define-scheme-predicate (null? obj) 337 | (null? obj)) 338 | 339 | (define-scheme-predicate (list? obj) 340 | (list? obj)) 341 | 342 | (define-scheme-procedure (make-list k &optional (fill nil)) 343 | (make-list k :initial-element fill)) 344 | 345 | (define-scheme-procedure (list . obj) 346 | (apply #'list obj)) 347 | 348 | (define-scheme-procedure (length list) 349 | (length list)) 350 | 351 | (define-scheme-procedure (append . lists) 352 | (apply #'append lists)) 353 | 354 | (define-scheme-procedure (reverse list) 355 | (reverse list)) 356 | 357 | (define-scheme-procedure (list-tail list k) 358 | (nthcdr k list)) 359 | 360 | (define-scheme-procedure (list-ref list k) 361 | (nth k list)) 362 | 363 | (define-scheme-procedure (list-set! list k obj) 364 | (setf (nth k list) obj)) 365 | 366 | (define-scheme-predicate (memq obj list) 367 | (member obj list :test #'eq)) 368 | 369 | (define-scheme-predicate (memv obj list) 370 | (member obj list :test #'eqv?)) 371 | 372 | (define-scheme-predicate (member obj list &optional compare) 373 | (member obj list :test (or #'equal? 374 | (lambda (x y) 375 | (false-to-nil (funcall compare x y)))))) 376 | 377 | (define-scheme-predicate (assq obj alist) 378 | (assoc obj alist :test #'eq)) 379 | 380 | (define-scheme-predicate (assv obj alist) 381 | (assoc obj alist :test #'eqv?)) 382 | 383 | (define-scheme-predicate (assoc obj alist &optional compare) 384 | (assoc obj alist :test (or #'equal? 385 | (lambda (x y) 386 | (false-to-nil (funcall compare x y)))))) 387 | 388 | (define-scheme-procedure (list-copy obj) 389 | (copy-list obj)) 390 | 391 | ;;;; 6.5 Symbols 392 | 393 | (define-scheme-predicate (symbol? obj) 394 | (symbol? obj)) 395 | 396 | (define-scheme-predicate (symbol=? . symbols) 397 | (apply #'symbol= symbols)) 398 | 399 | (define-scheme-procedure (symbol->string symbol) 400 | (scheme-symbol-name symbol)) 401 | 402 | (define-scheme-procedure (string->symbol string) 403 | (scheme-symbol string)) 404 | 405 | ;;;; 6.6 Characters 406 | 407 | (define-scheme-predicate (char? obj) 408 | (char? obj)) 409 | 410 | (define-scheme-predicate (char=? char . more-chars) 411 | (apply #'char= char more-chars)) 412 | 413 | (define-scheme-predicate (char? char . more-chars) 417 | (apply #'char> char more-chars)) 418 | 419 | (define-scheme-predicate (char<=? char . more-chars) 420 | (apply #'char<= char more-chars)) 421 | 422 | (define-scheme-predicate (char>=? char . more-chars) 423 | (apply #'char>= char more-chars)) 424 | 425 | (define-scheme-predicate (char-ci=? char . more-chars) 426 | (apply #'char-equal char more-chars)) 427 | 428 | (define-scheme-predicate (char-ci? char . more-chars) 432 | (apply #'char-greaterp char more-chars)) 433 | 434 | (define-scheme-predicate (char-ci<=? char . more-chars) 435 | (apply #'char-not-greaterp char more-chars)) 436 | 437 | (define-scheme-predicate (char-ci>=? char . more-chars) 438 | (apply #'char-not-lessp char more-chars)) 439 | 440 | (define-scheme-predicate (char-alphabetic? char) 441 | (char-alphabetic-p char)) 442 | 443 | (define-scheme-predicate (char-numeric? char) 444 | (char-numeric-p char)) 445 | 446 | (define-scheme-predicate (char-whitespace? char) 447 | (char-whitespace-p char)) 448 | 449 | (define-scheme-predicate (char-upper-case? letter) 450 | (char-lower-case-p letter)) 451 | 452 | (define-scheme-predicate (char-lower-case? letter) 453 | (char-lower-case-p letter)) 454 | 455 | (define-scheme-predicate (digit-value char) 456 | (digit-value char)) 457 | 458 | (define-scheme-procedure (char->integer char) 459 | (char-code char)) 460 | 461 | (define-scheme-procedure (integer->char n) 462 | (code-char n)) 463 | 464 | (define-scheme-procedure (char-upcase char) 465 | (char-upcase* char)) 466 | 467 | (define-scheme-procedure (char-downcase char) 468 | (char-downcase* char)) 469 | 470 | (define-scheme-procedure (char-foldcase char) 471 | (char-foldcase char)) 472 | 473 | ;;;; 6.7 Strings 474 | 475 | (define-scheme-predicate (string? obj) 476 | (string? obj)) 477 | 478 | (define-scheme-procedure (make-string k &optional (char #.(code-char 0))) 479 | (make-string k :initial-element char)) 480 | 481 | (define-scheme-procedure (string . char) 482 | (make-array (length char) :element-type 'character :initial-contents char)) 483 | 484 | (define-scheme-procedure (string-length string) 485 | (check-type string simple-string) 486 | (length string)) 487 | 488 | (define-scheme-procedure (string-ref string k) 489 | (char string k)) 490 | 491 | (define-scheme-procedure (string-set! string k char) 492 | (setf (char string k) char)) 493 | 494 | (define-scheme-predicate (string=? . strings) 495 | (apply #'string=? strings)) 496 | 497 | (define-scheme-predicate (string-ci=? . strings) 498 | (apply #'string-ci=? strings)) 499 | 500 | (define-scheme-predicate (string? . strings) 507 | (apply #'string>? strings)) 508 | 509 | (define-scheme-predicate (string-ci>? . strings) 510 | (apply #'string-ci>? strings)) 511 | 512 | (define-scheme-predicate (string<=? . strings) 513 | (apply #'string<=? strings)) 514 | 515 | (define-scheme-predicate (string-ci<=? . strings) 516 | (apply #'string-ci<=? strings)) 517 | 518 | (define-scheme-predicate (string>=? . strings) 519 | (apply #'string>=? strings)) 520 | 521 | (define-scheme-predicate (string-ci>=? . strings) 522 | (apply #'string-ci>=? strings)) 523 | 524 | (define-scheme-procedure (string-upcase string) 525 | (string-upcase* string)) 526 | 527 | (define-scheme-procedure (string-downcase string) 528 | (string-downcase* string)) 529 | 530 | (define-scheme-procedure (string-foldcase string) 531 | (string-foldcase string)) 532 | 533 | (define-scheme-procedure (substring string start end) 534 | (subseq string start end)) 535 | 536 | (define-scheme-procedure (string-append . string) 537 | (apply #'concatenate 'string string)) 538 | 539 | (define-scheme-procedure (string->list string &optional start end) 540 | (coerce-subseq string 'list start end)) 541 | 542 | (define-scheme-procedure (list->string list) 543 | (coerce list 'string)) 544 | 545 | (define-scheme-procedure (string-copy string &optional start end) 546 | (copy-seq-or-subseq string start end)) 547 | 548 | (define-scheme-procedure (string-copy! to at from &optional (start 0) end) 549 | (replace to from :start1 at :start2 start :end2 end)) 550 | 551 | (define-scheme-procedure (string-fill! string fill &optional (start 0) end) 552 | (fill string fill :start start :end end)) 553 | 554 | ;;;; 6.8 Vectors 555 | 556 | (define-scheme-predicate (vector? obj) 557 | (vector? obj)) 558 | 559 | (define-scheme-procedure (make-vector k &optional (fill nil)) 560 | (make-array k :initial-element fill)) 561 | 562 | (define-scheme-procedure (vector . obj) 563 | (apply #'vector obj)) 564 | 565 | (define-scheme-procedure (vector-length vector) 566 | (check-type vector vector?) 567 | (length vector)) 568 | 569 | (define-scheme-procedure (vector-ref vector k) 570 | (svref vector k)) 571 | 572 | (define-scheme-procedure (vector-set! vector k obj) 573 | (setf (svref vector k) obj)) 574 | 575 | (define-scheme-procedure (vector->list vector &optional start end) 576 | (check-type vector vector?) 577 | (coerce-subseq vector 'list start end)) 578 | 579 | (define-scheme-procedure (list->vector list) 580 | (coerce list 'vector?)) 581 | 582 | (define-scheme-procedure (vector->string vector &optional start end) 583 | (check-type vector vector?) 584 | (coerce-subseq vector 'string start end)) 585 | 586 | (define-scheme-procedure (string->vector string &optional start end) 587 | (coerce-subseq string 'scheme-vector start end)) 588 | 589 | (define-scheme-procedure (vector-copy vector &optional start end) 590 | (check-type vector vector?) 591 | (copy-seq-or-subseq vector start end)) 592 | 593 | (define-scheme-procedure (vector-copy! to at from &optional (start 0) end) 594 | (check-type to vector?) 595 | (check-type from vector?) 596 | (replace to from :start1 at :start2 start :end2 end)) 597 | 598 | (define-scheme-procedure (vector-append . vector) 599 | (apply #'concatenate 'simple-vector vector)) 600 | 601 | (define-scheme-procedure (vector-fill! vector fill &optional (start 0) end) 602 | (check-type vector vector?) 603 | (fill vector fill :start start :end end)) 604 | 605 | ;;;; 6.9 Bytevectors 606 | 607 | (define-scheme-predicate (bytevector? obj) 608 | (bytevector? obj)) 609 | 610 | (define-scheme-procedure (make-bytevector k &optional (byte 0)) 611 | (make-array k :element-type 'octet :initial-element byte)) 612 | 613 | (define-scheme-procedure (bytevector . byte) 614 | (make-array (length byte) :element-type 'octet :initial-contents byte)) 615 | 616 | (define-scheme-procedure (bytevector-length bytevector) 617 | (check-type bytevector bytevector?) 618 | (length bytevector)) 619 | 620 | (define-scheme-procedure (bytevector-u8-ref bytevector k) 621 | (check-type bytevector bytevector?) 622 | (aref bytevector k)) 623 | 624 | (define-scheme-procedure (bytevector-u8-set! bytevector k byte) 625 | (check-type bytevector bytevector?) 626 | (setf (aref bytevector k) byte)) 627 | 628 | (define-scheme-procedure (bytevector-copy bytevector &optional start end) 629 | (check-type bytevector bytevector?) 630 | (copy-seq-or-subseq bytevector start end)) 631 | 632 | (define-scheme-procedure (bytevector-copy! to at from &optional start end) 633 | (check-type to bytevector?) 634 | (check-type from bytevector?) 635 | (replace to from :start1 at :start2 start :end2 end)) 636 | 637 | (define-scheme-procedure (bytevector-append . bytevector) 638 | (apply #'concatenate 'bytevector bytevector)) 639 | 640 | (define-scheme-procedure (utf8->string bytevector &optional (start 0) end) 641 | (check-type bytevector bytevector?) 642 | (utf8-to-string bytevector :start start :end end)) 643 | 644 | (define-scheme-procedure (string->utf8 string &optional (start 0) end) 645 | (string-to-utf8 string :start start :end end)) 646 | 647 | ;;;; 6.10 Control features 648 | 649 | ;;; (procedure? obj) 650 | ;;; (apply proc arg . args) 651 | ;;; (map proc list . lists) 652 | ;;; (string-map proc string . strings) 653 | ;;; (vector-map proc vector . vectors) 654 | ;;; (for-each proc list . lists) 655 | ;;; (string-for-each proc string . strings) 656 | ;;; (vector-for-each proc vector . vectors) 657 | 658 | (%define-scheme-procedure (call-with-current-continuation continuation procedure) 659 | (multiple-value-call procedure continuation)) 660 | 661 | (%define-scheme-procedure (call/cc continuation procedure) 662 | (multiple-value-call procedure continuation)) 663 | 664 | (define-scheme-procedure (values . objs) 665 | (values-list objs)) 666 | 667 | ;;; (call-with-values producer consumer) 668 | ;;; (dynamic-wind before thunk after) 669 | 670 | ;;;; 6.11 Exceptions 671 | 672 | ;;; (with-exception-hander handler thunk) 673 | ;;; (raise obj) 674 | ;;; (raise-continuable obj) 675 | ;;; (error message . objs) 676 | ;;; (error-object? obj) 677 | ;;; (error-object-message error-object) 678 | ;;; (error-object-irritants error-object) 679 | ;;; (read-error? obj) 680 | ;;; (file-error? obj) 681 | 682 | ;;;; 6.12 Environments and evaluation 683 | 684 | ;;; (environment . lists) 685 | ;;; (scheme-report-environment version) 686 | ;;; (null-environment version) 687 | ;;; (interaction-environment) 688 | ;;; (eval expr-or-def environment-specifier) 689 | 690 | ;;;; 6.13 Input and output 691 | 692 | ;;; Ports 693 | 694 | ;;; (call-with-port port proc) 695 | ;;; (call-with-input-file string proc) 696 | ;;; (call-with-output-file string proc) 697 | 698 | (define-scheme-procedure (input-port? obj) 699 | (input-port? obj)) 700 | 701 | (define-scheme-procedure (output-port? obj) 702 | (output-port? obj)) 703 | 704 | (define-scheme-procedure (textual-port? obj) 705 | (and (streamp obj) 706 | (values (subtypep (stream-element-type obj) 707 | 'character)))) 708 | 709 | (define-scheme-procedure (binary-port? obj) 710 | (and (streamp obj) 711 | (values (subtypep (stream-element-type obj) 712 | 'integer)))) 713 | 714 | (define-scheme-procedure (port? obj) 715 | (port? obj)) 716 | 717 | (define-scheme-procedure (input-port-open? port) 718 | (and (input-stream-p port) 719 | (open-stream-p port))) 720 | 721 | (define-scheme-procedure (output-port-open? port) 722 | (and (output-stream-p port) 723 | (open-stream-p port))) 724 | 725 | ;;; (current-input-port) 726 | ;;; (current-output-port) 727 | ;;; (current-error-port) 728 | ;;; (with-input-from-file string thunk) 729 | ;;; (with-output-to-file string thunk) 730 | ;;; (open-input-file string) 731 | ;;; (open-binary-input-file string) 732 | ;;; (open-output-file string) 733 | ;;; (open-binary-output-file string) 734 | ;;; (close-port port) 735 | ;;; (close-input-port port) 736 | ;;; (close-output-port port) 737 | ;;; (open-input-string string) 738 | ;;; (open-output-string) 739 | ;;; (get-output-string port) 740 | ;;; (open-input-bytevector bytevector) 741 | ;;; (open-output-bytevector) 742 | ;;; (get-output-bytevector port) 743 | 744 | ;;; Input 745 | 746 | ;;; (read &optional port) 747 | ;;; (read-char &optional port) 748 | ;;; (peek-char &optional port) 749 | ;;; (read-line &optional port) 750 | ;;; (eof-object? obj) 751 | ;;; (eof-object) 752 | ;;; (char-ready? &optional port) 753 | ;;; (read-string k &optional port) 754 | ;;; (read-u8 &optional port) 755 | ;;; (peek-u8 &optional port) 756 | ;;; (u8-ready? &optional port) 757 | ;;; (read-bytevector k &optional port) 758 | ;;; (read-bytevector! bytevector &optional port start end) 759 | 760 | ;;; Output 761 | 762 | ;;; (write obj &optional port) 763 | ;;; (write-shared obj &optional port) 764 | ;;; (write-simple obj &optional port) 765 | ;;; (display obj &optional port) 766 | ;;; (newline &optional port) 767 | ;;; (write-char char &optional port) 768 | ;;; (write-string string &optional port start end) 769 | ;;; (write-u8 byte &optional port) 770 | ;;; (write-bytevector bytevector &optional port start end) 771 | ;;; (flush-output-port &optional port) 772 | 773 | ;;;; 6.14 System interface 774 | 775 | ;;; (load filename &optional environment-specifier) 776 | ;;; (file-exists? filename) 777 | ;;; (delete-file filename) 778 | ;;; (command-line) 779 | ;;; (exit &optional obj) 780 | ;;; (emergency-exit &optional obj) 781 | ;;; (get-environment-variable &optional name) 782 | ;;; (current-second) 783 | 784 | (define-scheme-procedure (current-jiffy) 785 | (get-internal-real-time)) 786 | 787 | (define-scheme-procedure (jiffies-per-second) 788 | internal-time-units-per-second) 789 | 790 | (define-scheme-procedure (features) 791 | '(r7rs 792 | exact-closed 793 | exact-complex 794 | ;; CCL doesn't have this in *features*, but SBCL and ECL do. 795 | #+(or ccl ieee-floating-point) ieee-float 796 | ;; TODO: other implementations might also have full Unicode 797 | #+(and sbcl sb-unicode) full-unicode 798 | ratios 799 | #+unix posix 800 | ;; Features guaranteed by trivial-features 801 | #+unix unix 802 | #+windows windows 803 | #+linux linux 804 | #+bsd bsd 805 | #+darwin darwin 806 | #+x86 x86 807 | #+x86-64 x86-64 808 | #+ppc ppc 809 | #+32-bit 32-bit 810 | #+64-bit 64-bit 811 | #+big-endian big-endian 812 | #+little-endian little-endian 813 | ;; Supported CL implementations for now 814 | #+sbcl sbcl 815 | #+ccl ccl 816 | #+ecl ecl 817 | ;; Threads, if bordeaux-threads is loaded 818 | #+thread-support thread-support 819 | ;; Features describing this Scheme 820 | airship 821 | airship-scheme 822 | airship-scheme-0)) 823 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (defpackage #:airship-scheme/tests 4 | (:use #:airship-scheme 5 | #:cl) 6 | (:import-from #:5am 7 | #:is) 8 | (:export #:airship-scheme/tests) 9 | (:local-nicknames (:scheme :airship-scheme) 10 | (:f :float-features))) 11 | -------------------------------------------------------------------------------- /tests/test-script.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:test-script 2 | (:use #:cl)) 3 | 4 | (in-package #:test-script) 5 | 6 | ;;; Load the test suite and UIOP at read time. 7 | #.(progn (ql:quickload :fiveam :silent t) 8 | (ql:quickload :uiop :silent t) 9 | nil) 10 | 11 | ;;; Turn on full type inference to catch more type errors when 12 | ;;; compiling. 13 | #+sbcl 14 | (setf sb-ext:*derive-function-types* t) 15 | 16 | ;;; Load the dependencies first because if they have warnings, there's 17 | ;;; nothing we can do about that. 18 | (dolist (system (asdf:system-depends-on (asdf:find-system :airship-scheme))) 19 | (ql:quickload system :silent t)) 20 | 21 | ;;; The first "test" is to compile with no warnings. 22 | (let ((asdf:*compile-file-warnings-behaviour* :error)) 23 | (ql:quickload :airship-scheme :verbose t) 24 | (ql:quickload :airship-scheme/tests)) 25 | 26 | ;;; Run the tests. 27 | ;;; 28 | ;;; Ideally, we could just work with the final return value of the 29 | ;;; fiveam tests from asdf:test-system, but asdf:test-system always 30 | ;;; returns t, so fiveam has to be used directly. 31 | (defun run-tests () 32 | (fiveam:run! 'airship-scheme/tests:airship-scheme/tests)) 33 | 34 | ;;; This lets Gitlab CI know that something went wrong. 35 | (unless (run-tests) 36 | (uiop:quit 1)) 37 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme/tests) 4 | 5 | (defun read-scheme* (string) 6 | (with-input-from-string (stream string) 7 | (scheme::read-scheme stream))) 8 | 9 | (5am:def-suite airship-scheme/tests) 10 | 11 | (5am:def-suite airship-scheme/scheme-read 12 | :in airship-scheme/tests) 13 | 14 | (5am:in-suite airship-scheme/scheme-read) 15 | 16 | (5am:test boolean-syntax 17 | "Are true and false read correctly?" 18 | (is (eq (read-scheme* "#t") t)) 19 | (is (eq (read-scheme* "#true") t)) 20 | (is (eq (read-scheme* "#TrUe") t)) 21 | (is (eq (read-scheme* "#tRuE") t)) 22 | (is (eq (read-scheme* "#TRUE") t)) 23 | (is (eq (car (read-scheme* "(#t)")) t)) 24 | (is (eq (car (read-scheme* "(#true)")) t)) 25 | (is (eq (read-scheme* "#f") %scheme-boolean:f)) 26 | (is (eq (read-scheme* "#false") %scheme-boolean:f)) 27 | (is (eq (read-scheme* "#FaLsE") %scheme-boolean:f)) 28 | (is (eq (read-scheme* "#fAlSe") %scheme-boolean:f)) 29 | (is (eq (read-scheme* "#FALSE") %scheme-boolean:f)) 30 | (is (eq (car (read-scheme* "(#f)")) %scheme-boolean:f)) 31 | (is (eq (car (read-scheme* "(#false)")) %scheme-boolean:f)) 32 | (is (eq '%scheme-boolean:f %scheme-boolean:f))) 33 | 34 | ;;; Note: This should match the list of numbers in examples/syntax.scm 35 | (5am:test numeric-syntax 36 | "Are numbers read correctly?" 37 | (is (eql (read-scheme* "1") 38 | 1)) 39 | (is (eql (read-scheme* "+1") 40 | 1)) 41 | (is (eql (read-scheme* "-1") 42 | -1)) 43 | (is (eql (read-scheme* "1.0") 44 | 1.0d0)) 45 | (is (eql (read-scheme* "4.") 46 | 4.0d0)) 47 | (is (eql (read-scheme* ".4") 48 | 0.4d0)) 49 | (is (eql (read-scheme* "-.4") 50 | -0.4d0)) 51 | (is (eql (read-scheme* "+.4") 52 | 0.4d0)) 53 | (is (eql (read-scheme* "1.0f0") 54 | 1.0f0)) 55 | (is (eql (read-scheme* "-1.2s3") 56 | -1.2s3)) 57 | (is (eql (read-scheme* "1.0l-1") 58 | 1.0l-1)) 59 | (is (eql (read-scheme* "3d1") 60 | 3d1)) 61 | (is (eql (read-scheme* "87e2") 62 | 87d2)) 63 | (is (eql (read-scheme* "4/3") 64 | 4/3)) 65 | (is (eql (read-scheme* "-123/456") 66 | -123/456)) 67 | (is (eql (read-scheme* "-3/2") 68 | -3/2)) 69 | (is (eql (read-scheme* "-4i") 70 | #C(0 -4))) 71 | (is (eql (read-scheme* "+3i") 72 | #C(0 3))) 73 | (is (eql (read-scheme* "7i") 74 | #C(0 7))) 75 | (is (eql (read-scheme* "4-i") 76 | #C(4 -1))) 77 | (is (eql (read-scheme* "9+i") 78 | #C(9 1))) 79 | (is (eql (read-scheme* "4/3-3/4i") 80 | #C(4/3 -3/4))) 81 | (is (eql (read-scheme* "3e4-4e4i") 82 | #C(3d4 -4d4))) 83 | (is (eql (read-scheme* "-4.0f30+3.0f20i") 84 | #C(-4.0f30 3.0f20))) 85 | (is (eql (read-scheme* "-1+4i") 86 | #C(-1 4))) 87 | (is (eql (read-scheme* "+4-3i") 88 | #C(4 -3))) 89 | (is (eql (read-scheme* "3+2i") 90 | #C(3 2))) 91 | (let* ((z (read-scheme* "4@5")) 92 | (z* (* 4d0 (cis 5d0))) 93 | (z-z* (- z z*))) 94 | (is (and (typep z '(complex double-float)) 95 | (< (abs (realpart z-z*)) double-float-epsilon) 96 | (< (abs (imagpart z-z*)) double-float-epsilon)))) 97 | (let* ((z (read-scheme* "-3.0@+4e3")) 98 | (z* (* -3d0 (cis 4d3))) 99 | (z-z* (- z z*))) 100 | (is (and (typep z '(complex double-float)) 101 | (< (abs (realpart z-z*)) double-float-epsilon) 102 | (< (abs (imagpart z-z*)) double-float-epsilon)))) 103 | (let* ((z (read-scheme* "-321.0f-3@+432f12")) 104 | (z* (* -321.0f-3 (cis 432f12))) 105 | (z-z* (- z z*))) 106 | (is (and (typep z '(complex single-float)) 107 | (< (abs (realpart z-z*)) single-float-epsilon) 108 | (< (abs (imagpart z-z*)) single-float-epsilon))))) 109 | 110 | (5am:test infnan-syntax 111 | "Are the 'infnan' numbers read correctly?" 112 | (is (eql (read-scheme* "+inf.0") 113 | f:double-float-positive-infinity)) 114 | (is (eql (read-scheme* "-inf.0") 115 | f:double-float-negative-infinity)) 116 | (let ((nan (read-scheme* "+nan.0"))) 117 | (is (and (scheme::nanp nan) 118 | (typep nan 'double-float) 119 | (not (scheme::sign-bit? nan))))) 120 | (let ((nan (read-scheme* "-nan.0"))) 121 | (is (and (scheme::nanp nan) 122 | (typep nan 'double-float) 123 | (scheme::sign-bit? nan)))) 124 | (is (eql (read-scheme* "+inf.0f0") 125 | f:single-float-positive-infinity)) 126 | (is (eql (read-scheme* "-inf.0f0") 127 | f:single-float-negative-infinity)) 128 | (let ((nan (read-scheme* "+nan.0f0"))) 129 | (is (and (scheme::nanp nan) 130 | (typep nan 'single-float) 131 | (not (scheme::sign-bit? nan))))) 132 | (let ((nan (read-scheme* "-nan.0f0"))) 133 | (is (and (scheme::nanp nan) 134 | (typep nan 'single-float) 135 | (scheme::sign-bit? nan)))) 136 | (is (eql (read-scheme* "+inf.0+inf.0i") 137 | (complex f:double-float-positive-infinity 138 | f:double-float-positive-infinity))) 139 | (let ((z (read-scheme* "+inf.0-nan.0i"))) 140 | (is (eql (realpart z) 141 | f:double-float-positive-infinity)) 142 | (let ((i (imagpart z))) 143 | (is (and (scheme::nanp i) 144 | (typep i 'double-float) 145 | (scheme::sign-bit? i))))) 146 | (let ((z (read-scheme* "+nan.0+inf.0i"))) 147 | (is (eql (imagpart z) 148 | f:double-float-positive-infinity)) 149 | (let ((x (realpart z))) 150 | (is (and (scheme::nanp x) 151 | (typep x 'double-float) 152 | (not (scheme::sign-bit? x)))))) 153 | (is (eql (read-scheme* "4-inf.0i") 154 | (complex 4.0d0 155 | f:double-float-negative-infinity))) 156 | (let ((z (read-scheme* "-12+nan.0f0i"))) 157 | (is (eql (realpart z) 158 | -12.0f0)) 159 | (let ((i (imagpart z))) 160 | (is (and (scheme::nanp i) 161 | (typep i 'single-float) 162 | (not (scheme::sign-bit? i)))))) 163 | (is (eql (read-scheme* "+inf.0-3i") 164 | (complex f:double-float-positive-infinity 165 | -3.0d0))) 166 | (let ((z (read-scheme* "-nan.0+42i"))) 167 | (is (eql (imagpart z) 168 | 42.0d0)) 169 | (let ((x (realpart z))) 170 | (is (and (scheme::nanp x) 171 | (typep x 'double-float) 172 | (scheme::sign-bit? x))))) 173 | (let ((z (read-scheme* "-nan.0f0-333i"))) 174 | (is (eql (imagpart z) 175 | -333.0f0)) 176 | (let ((x (realpart z))) 177 | (is (and (scheme::nanp x) 178 | (typep x 'single-float) 179 | (scheme::sign-bit? x))))) 180 | (let ((z (read-scheme* "-nan.0f0+inf.0f0i"))) 181 | (is (eql (imagpart z) 182 | f:single-float-positive-infinity)) 183 | (let ((x (realpart z))) 184 | (is (and (scheme::nanp x) 185 | (typep x 'single-float) 186 | (scheme::sign-bit? x))))) 187 | (is (eql (read-scheme* "+inf.0f0+22i") 188 | (complex f:single-float-positive-infinity 189 | 22f0))) 190 | (let ((z (read-scheme* "+inf.0f0-nan.0f0i"))) 191 | (is (eql (realpart z) 192 | f:single-float-positive-infinity)) 193 | (let ((i (imagpart z))) 194 | (is (and (scheme::nanp i) 195 | (typep i 'single-float) 196 | (scheme::sign-bit? i))))) 197 | (let ((z (read-scheme* "333+nan.0f0i"))) 198 | (is (eql (realpart z) 199 | 333.0f0)) 200 | (let ((i (imagpart z))) 201 | (is (and (scheme::nanp i) 202 | (typep i 'single-float) 203 | (not (scheme::sign-bit? i)))))) 204 | (is (eql (read-scheme* "+inf.0i") 205 | (complex 0d0 206 | f:double-float-positive-infinity))) 207 | (is (eql (read-scheme* "-inf.0f0i") 208 | (complex 0f0 209 | f:single-float-negative-infinity))) 210 | (let ((z (read-scheme* "-nan.0i"))) 211 | (is (eql (realpart z) 0d0)) 212 | (let ((i (imagpart z))) 213 | (is (and (scheme::nanp i) 214 | (typep i 'double-float) 215 | (scheme::sign-bit? i))))) 216 | (let ((z (read-scheme* "+nan.0d0i"))) 217 | (is (eql (realpart z) 0d0) 218 | (let ((i (imagpart z))) 219 | (is (and (scheme::nanp i) 220 | (typep i 'double-float) 221 | (not (scheme::sign-bit? i))))))) 222 | (let ((z (read-scheme* "4@+inf.0"))) 223 | (is (and (typep z '(complex double-float)) 224 | (scheme::nanp (realpart z)) 225 | (scheme::nanp (imagpart z))))) 226 | (let ((z (read-scheme* "-7@-nan.0"))) 227 | (is (and (typep z '(complex double-float)) 228 | (scheme::nanp (realpart z)) 229 | (scheme::nanp (imagpart z))))) 230 | (eql (read-scheme* "+inf.0f0@111") 231 | (complex f:single-float-negative-infinity 232 | f:single-float-negative-infinity)) 233 | (eql (read-scheme* "+inf.0@-3") 234 | (complex f:double-float-negative-infinity 235 | f:double-float-negative-infinity)) 236 | (let ((z (read-scheme* "+nan.0@42"))) 237 | (is (and (typep z '(complex double-float)) 238 | (scheme::nanp (realpart z)) 239 | (scheme::nanp (imagpart z))))) 240 | (let ((z (read-scheme* "+inf.0@-inf.0"))) 241 | (is (and (typep z '(complex double-float)) 242 | (scheme::nanp (realpart z)) 243 | (scheme::nanp (imagpart z))))) 244 | (let ((z (read-scheme* "-nan.0@+nan.0"))) 245 | (is (and (typep z '(complex double-float)) 246 | (scheme::nanp (realpart z)) 247 | (scheme::nanp (imagpart z))))) 248 | (let ((z (read-scheme* "+nan.0f0@-nan.0f0"))) 249 | (is (and (typep z '(complex single-float)) 250 | (scheme::nanp (realpart z)) 251 | (scheme::nanp (imagpart z)))))) 252 | 253 | (5am:test read-bases-and-exactness 254 | "Are numbers in different bases and exactness read correctly?" 255 | (is (eql (read-scheme* "#x42") 66)) 256 | (is (eql (read-scheme* "#xFFF") 4095)) 257 | (is (eql (read-scheme* "#Xfff") 4095)) 258 | (is (eql (read-scheme* "#XffF") 4095)) 259 | (is (eql (read-scheme* "#b101") 5)) 260 | (is (eql (read-scheme* "#o777") 511)) 261 | (is (eql (read-scheme* "#d1999") 1999)) 262 | (is (eql (read-scheme* "#xabcdef") 11259375)) 263 | (is (eql (read-scheme* "#i33") 33.0d0)) 264 | (is (eql (read-scheme* "#e876") 876)) 265 | (is (eql (read-scheme* "#e876.0") 876)) 266 | (is (eql (read-scheme* "#e32.1") 321/10)) 267 | (is (eql (read-scheme* "#x#iee") 238.0d0)) 268 | (is (eql (read-scheme* "#i#xcd") 205.0d0)) 269 | (is (eql (read-scheme* "#e#x1a") 26)) 270 | (is (eql (read-scheme* "#x#e93fc3a") 9698362)) 271 | (is (eql (read-scheme* "#i#o4321") 2257.0d0)) 272 | (is (eql (read-scheme* "#b#i1110101010100001") 60065.0d0)) 273 | (is (eql (read-scheme* "#e1e500") (expt 10 500))) 274 | (is (eql (read-scheme* "#e#d1e500") (expt 10 500))) 275 | (is (eql (read-scheme* "#d#e1e500") (expt 10 500)))) 276 | 277 | (5am:test read-symbols 278 | "Are symbols read correctly?" 279 | (is (string= (symbol-name (read-scheme* "hello")) 280 | "HELLO")) 281 | (is (string= (symbol-name (read-scheme* "WORLD")) 282 | "world")) 283 | (is (string= (symbol-name (read-scheme* "TeSt")) 284 | "tEsT")) 285 | (is (string= (symbol-name (read-scheme* "|hello|")) 286 | "HELLO")) 287 | (is (string= (symbol-name (read-scheme* "|HELLO|")) 288 | "hello")) 289 | (is (string= (symbol-name (read-scheme* "|This is a sentence.|")) 290 | "tHIS IS A SENTENCE.")) 291 | (is (string= (symbol-name (read-scheme* "||")) 292 | "")) 293 | (is (string= (symbol-name (read-scheme* "|foo\\nbar|")) 294 | (format nil "FOO~%BAR"))) 295 | (is (string= (symbol-name (read-scheme* "|foo\\tbar|")) 296 | "FOO BAR")) 297 | (is (string= (symbol-name (read-scheme* (format nil "|foo \\~%bar|"))) 298 | "FOO BAR")) 299 | (is (string= (symbol-name (read-scheme* "|escaped bar: \\||")) 300 | "ESCAPED BAR: \|"))) 301 | 302 | (defun quoted? (form) 303 | (and (listp form) (eql (car form) 'quote) (cdr form) (endp (cddr form)))) 304 | 305 | (defun quote-contents (quoted-form) 306 | (cadr quoted-form)) 307 | 308 | (5am:test read-quoted 309 | "Are quoted things read correctly?" 310 | (let ((quoted-a (read-scheme* "'a"))) 311 | (is (and (quoted? quoted-a) 312 | (eql (quote-contents quoted-a) 'a)))) 313 | (let* ((double-quoted-a (read-scheme* "''a")) 314 | (quoted-a (quote-contents double-quoted-a))) 315 | (is (and (quoted? double-quoted-a) 316 | (quoted? quoted-a) 317 | (eql (quote-contents quoted-a) 'a)))) 318 | (is (equalp (read-scheme* "'(0 1 1 2 3 5)") ''(0 1 1 2 3 5)))) 319 | 320 | (5am:test string-escaped-characters 321 | "Do literal strings correctly handle escaped characters?" 322 | (is (char= (char (read-scheme* "\"\\n\"") 0) (code-char #x000a))) 323 | (is (char= (char (read-scheme* "\"\\t\"") 0) (code-char #x0009))) 324 | (is (char= (char (read-scheme* "\"\\a\"") 0) (code-char #x0007))) 325 | (is (char= (char (read-scheme* "\"\\b\"") 0) (code-char #x0008))) 326 | (is (char= (char (read-scheme* "\"\\r\"") 0) (code-char #x000d))) 327 | (let ((backslash (read-scheme* "\"\\\\\""))) 328 | (is (and (= 1 (length backslash)) 329 | (char= (char backslash 0) #\\)))) 330 | (is (string= (read-scheme* "\"escaped double quote: \\\"\"") 331 | "escaped double quote: \"")) 332 | (is (char= (char (read-scheme* "\"\\x42;\"") 0) #\B)) 333 | (is (string= (read-scheme* (format nil "\"foo \\~%bar\"")) 334 | "foo bar")) 335 | (is (string= (read-scheme* (format nil "\"foo \\ ~%bar\"")) 336 | "foo bar")) 337 | (is (string= (read-scheme* (format nil "\"foo \\ ~%bar\"")) 338 | "foo bar")) 339 | (is (string= (read-scheme* (format nil "\"foo \\ ~%bar\"")) 340 | "foo bar"))) 341 | 342 | (5am:test literal-characters 343 | "Are the literal characters read properly?" 344 | (is (char= (read-scheme* "#\\alarm") (code-char #x0007))) 345 | (is (char= (read-scheme* "#\\backspace") (code-char #x0008))) 346 | (is (char= (read-scheme* "#\\delete") (code-char #x007f))) 347 | (is (char= (read-scheme* "#\\escape") (code-char #x001b))) 348 | (is (char= (read-scheme* "#\\newline") (code-char #x000a))) 349 | (is (char= (read-scheme* "#\\null") (code-char #x0000))) 350 | (is (char= (read-scheme* "#\\return") (code-char #x000d))) 351 | (is (char= (read-scheme* "#\\space") (char " " 0))) 352 | (is (char= (read-scheme* "#\\tab") (char " " 0))) 353 | (is (char= (read-scheme* "#\\x53") #\S)) 354 | (is (char= (read-scheme* "#\\X79") #\y)) 355 | (is (char= (read-scheme* "#\\x221E") #\∞)) 356 | (is (char= (read-scheme* "#\\xe9") #\é))) 357 | 358 | (5am:test read-sequences 359 | "Does Airship Scheme correctly read sequences?" 360 | (let ((scheme-sequence (read-scheme* "(a b c d e f g 1 2 3)")) 361 | (lisp-sequence '(a b c d e f g 1 2 3))) 362 | (is (and (typep scheme-sequence 'list) 363 | (= (length scheme-sequence) (length lisp-sequence)) 364 | (every #'eql scheme-sequence lisp-sequence)))) 365 | (is (equalp (read-scheme* "(a . b)") '(a . b))) 366 | (is (equalp (read-scheme* "(1 2 . 3)") '(1 2 . 3))) 367 | (let ((scheme-sequence (read-scheme* "\"z y x Z Y X\"")) 368 | (lisp-sequence "z y x Z Y X")) 369 | (is (and (typep scheme-sequence 'simple-string) 370 | (string= scheme-sequence lisp-sequence)))) 371 | (let ((scheme-sequence (read-scheme* "#(9 8 7 a b c)")) 372 | (lisp-sequence #(9 8 7 a b c))) 373 | (is (and (typep scheme-sequence 'simple-vector)) 374 | (= (length scheme-sequence) (length lisp-sequence)) 375 | (every #'eql scheme-sequence lisp-sequence))) 376 | (let ((scheme-sequence (read-scheme* "#u8(99 98 97)")) 377 | (lisp-sequence (make-array 3 378 | :element-type '(unsigned-byte 8) 379 | :initial-contents '(99 98 97)))) 380 | (is (and (typep scheme-sequence '(simple-array (unsigned-byte 8) (*)))) 381 | (= (length scheme-sequence) (length lisp-sequence)) 382 | (every #'= scheme-sequence lisp-sequence))) 383 | (let ((scheme-sequence (read-scheme* "#u8(#x0f #xfe #xed #xdc #xcb)")) 384 | (lisp-sequence (make-array 5 385 | :element-type '(unsigned-byte 8) 386 | :initial-contents '(#x0f #xfe #xed #xdc #xcb)))) 387 | (is (and (typep scheme-sequence '(simple-array (unsigned-byte 8) (*)))) 388 | (= (length scheme-sequence) (length lisp-sequence)) 389 | (every #'= scheme-sequence lisp-sequence)))) 390 | 391 | (defmacro scheme (expression) 392 | (destructuring-bind (symbol &rest rest) expression 393 | `(,(intern (symbol-name symbol) 'r7rs) #'identity ,@rest))) 394 | 395 | (defmacro scheme* (expression) 396 | (destructuring-bind (symbol &rest rest) expression 397 | `(,(intern (symbol-name symbol) 'r7rs) #'values ,@rest))) 398 | 399 | ;;; TODO: equivalence predicates 400 | 401 | (5am:test arithmetic 402 | "Are the arithmetic procedures correct?" 403 | (is (eql (scheme (+ 1)) 1)) 404 | (is (eql (scheme (+ 8 3)) 11)) 405 | (is (eql (scheme (+ 5 4 -3)) 6)) 406 | (is (eql (scheme (+)) 0)) 407 | (is (eql (scheme (- 42)) -42)) 408 | (is (eql (scheme (- 4321 1234)) 3087)) 409 | (is (eql (scheme (*)) 1)) 410 | (is (eql (scheme (* 32)) 32)) 411 | (is (eql (scheme (* 28 48)) 1344)) 412 | (is (eql (scheme (/ 4)) 1/4)) 413 | (is (eql (scheme (/ 3 7)) 3/7)) 414 | (is (eql (scheme (/ 46 2)) 23)) 415 | (is (eql (scheme (/ 46d0 2d0)) 23d0)) 416 | (is (eql (scheme (abs -479678)) 479678)) 417 | (is (eql (scheme (abs 742)) 742)) 418 | (is (eql (scheme (abs -674.578d0)) 674.578d0)) 419 | (is (eql (scheme (abs 976.798d0)) 976.798d0)) 420 | (is (equal (multiple-value-list (scheme* (floor/ 17 8))) 421 | (list 2 1)))) 422 | 423 | (defun boolean-true? (expression) 424 | " 425 | Returns T if the expression is both true and a boolean. This is 426 | necessary because all values are true other than NIL. This ensures 427 | that all Common Lisp implementations return the same result for 428 | Airship Scheme, which isn't guaranteed without this predicate. 429 | " 430 | (eql expression t)) 431 | 432 | (defun scheme-not (expression) 433 | "Returns T if the expression is false in Scheme." 434 | (eql expression %scheme-boolean:f)) 435 | 436 | (5am:test numerical-predicates 437 | "Are the numerical predicates correct?" 438 | (is (boolean-true? (scheme (number? 42)))) 439 | (is (scheme-not (scheme (number? "hello")))) 440 | (is (boolean-true? (scheme (complex? 58d0)))) 441 | (is (boolean-true? (scheme (complex? #C(3.0f0 2.0f0))))) 442 | (is (boolean-true? (scheme (real? 3)))) 443 | (is (scheme-not (scheme (real? #C(842 546))))) 444 | (is (boolean-true? (scheme (rational? 8)))) 445 | (is (boolean-true? (scheme (rational? 73/2)))) 446 | (is (boolean-true? (scheme (integer? 259361371606)))) 447 | (is (boolean-true? (scheme (integer? 259361371606.0f0)))) 448 | (is (boolean-true? (scheme (integer? 259361371606.0d0)))) 449 | (is (boolean-true? (scheme (exact-integer? 259361371606)))) 450 | (is (scheme-not (scheme (exact-integer? 259361371606.0f0)))) 451 | (is (scheme-not (scheme (exact-integer? 259361371606.0d0)))) 452 | (is (and (boolean-true? (scheme (exact? 22/7))) 453 | (scheme-not (scheme (inexact? 22/7))))) 454 | (is (and (scheme-not (scheme (exact? 3.14f0))) 455 | (boolean-true? (scheme (inexact? 3.14f0))))) 456 | (is (and (scheme-not (scheme (exact? 3.14d0))) 457 | (boolean-true? (scheme (inexact? 3.14d0))))) 458 | (is (and (boolean-true? (scheme (finite? 749856))) 459 | (scheme-not (scheme (infinite? 749856))) 460 | (scheme-not (scheme (nan? 749856))))) 461 | (is (and (scheme-not (scheme (finite? (read-scheme* "+inf.0")))) 462 | (boolean-true? (scheme (infinite? (read-scheme* "+inf.0")))) 463 | (scheme-not (scheme (nan? (read-scheme* "+inf.0")))))) 464 | (is (and (scheme-not (scheme (finite? (read-scheme* "+nan.0")))) 465 | (scheme-not (scheme (infinite? (read-scheme* "+nan.0")))) 466 | (boolean-true? (scheme (nan? (read-scheme* "+nan.0")))))) 467 | (is (and (boolean-true? (scheme (zero? 0))) 468 | (boolean-true? (scheme (zero? 0.0f0))) 469 | (boolean-true? (scheme (zero? 0.0d0))) 470 | (boolean-true? (scheme (zero? (read-scheme* "0.0+0.0i")))) 471 | (boolean-true? (scheme (zero? (read-scheme* "0.0f0+0.0f0i")))))) 472 | (is (and (scheme-not (scheme (positive? 0))) 473 | (scheme-not (scheme (negative? 0))))) 474 | (is (and (scheme-not (scheme (zero? 42))) 475 | (scheme-not (scheme (zero? -1d0))))) 476 | (is (and (boolean-true? (scheme (positive? 42.0f0))) 477 | (scheme-not (scheme (positive? -42.0f0))))) 478 | (is (and (boolean-true? (scheme (negative? -42.0f0))) 479 | (scheme-not (scheme (negative? 42.0f0))))) 480 | (is (and (boolean-true? (scheme (even? 0))) 481 | (scheme-not (scheme (odd? 0))))) 482 | (is (and (boolean-true? (scheme (even? 756))) 483 | (scheme-not (scheme (odd? 756))))) 484 | (is (and (boolean-true? (scheme (odd? -99))) 485 | (scheme-not (scheme (even? -99)))))) 486 | 487 | ;;; TODO: the rest of the number procedures 488 | 489 | ;;; TODO: number->string string->number 490 | 491 | ;;; TODO: booleans 492 | ;;; TODO: pairs 493 | ;;; TODO: lists 494 | ;;; TODO: symbols 495 | ;;; TODO: characters 496 | 497 | ;;; TODO: string? string-ci>? string<=? 498 | ;;; string-ci<=? string>=? string-ci>=? 499 | ;;; 500 | ;;; TODO: string-upcase string-downcase string-foldcase substring 501 | ;;; string-append string->list list->string string-copy string-copy! 502 | (5am:test strings 503 | "Are the string procedures correct?" 504 | (is (boolean-true? (scheme (string? "Hello")))) 505 | (is (scheme-not (scheme (string? #(0 1 2))))) 506 | (is (scheme-not (scheme (string? 42)))) 507 | (is (scheme-not (scheme (string? '(1 2 3))))) 508 | (is (scheme-not (scheme (string? #(#\A #\B #\C))))) 509 | (is (scheme-not (scheme (string? '(#\A #\B #\C))))) 510 | (let ((s (scheme (make-string 5)))) 511 | (is (boolean-true? (scheme (string? s)))) 512 | (is (= 5 (length s) (scheme (string-length s))))) 513 | (let ((s (scheme (make-string 5 #\Z)))) 514 | (is (and (boolean-true? (scheme (string=? s "ZZZZZ"))) 515 | (boolean-true? (scheme (string=? "ZZZZZ" s))))) 516 | (is (and (scheme-not (scheme (string=? s "zzzzz"))) 517 | (scheme-not (scheme (string=? "zzzzz" s))))) 518 | (is (scheme-not (scheme (string=? s "ZZZ")))) 519 | (is (and (boolean-true? (scheme (string-ci=? "ZZZZZ" s))) 520 | (boolean-true? (scheme (string-ci=? s "ZZZZZ"))))) 521 | (is (and (boolean-true? (scheme (string-ci=? "zzzzz" s))) 522 | (boolean-true? (scheme (string-ci=? s "zzzzz")))))) 523 | (let ((s (scheme (string #\a #\b #\c)))) 524 | (is (and (string= s "abc") 525 | (scheme (string=? s "abc")))) 526 | (is (and (eql #\a (scheme (string-ref s 0))) 527 | (eql #\b (scheme (string-ref s 1))) 528 | (eql #\c (scheme (string-ref s 2))))) 529 | (progn 530 | (scheme (string-set! s 1 #\B)) 531 | (is (and (string= s "aBc") 532 | (scheme (string=? s "aBc")) 533 | (eql #\B (scheme (string-ref s 1))) 534 | (eql #\B (aref s 1)))) 535 | (scheme (string-fill! s #\z)) 536 | (is (and (string= s "zzz") 537 | (scheme (string=? s "zzz")) 538 | (eql #\z (scheme (string-ref s 2))) 539 | (eql #\z (aref s 2)))) 540 | (scheme (string-fill! s #\x 1)) 541 | (is (and (string= s "zxx") 542 | (scheme (string=? s "zxx")) 543 | (eql #\x (scheme (string-ref s 2))) 544 | (eql #\x (aref s 2)))) 545 | (scheme (string-fill! s #\y 1 2)) 546 | (is (and (string= s "zyx") 547 | (scheme (string=? s "zyx")) 548 | (eql #\y (scheme (string-ref s 1))) 549 | (eql #\x (aref s 2))))))) 550 | 551 | ;;; TODO: vectors, bytevectors 552 | 553 | ;;; TODO: 6.10 6.11 6.12 6.13 6.14 554 | 555 | ;;; TODO: cl-environment and SRFI 112 556 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- mode: common-lisp; -*- 2 | 3 | (in-package #:airship-scheme) 4 | 5 | (define-function (make-adjustable-string :inline t) (&optional (length 16)) 6 | "Creates an adjustable string of the given initial length." 7 | (make-array length 8 | :element-type 'character 9 | :adjustable t 10 | :fill-pointer 0)) 11 | 12 | (define-function (nil-to-false :inline t) (item) 13 | " 14 | Handles the result of a CL predicate, which uses NIL as its false 15 | value, by turning nil into the #f that Airship Scheme expects. 16 | " 17 | (if item item '%scheme-boolean:f)) 18 | 19 | (define-function (false-to-nil :inline t) (item) 20 | " 21 | Processes the result of a Scheme procedure by turning Scheme's #f into 22 | the NIL that CL expects to be the false value. 23 | " 24 | (if (eq item '%scheme-boolean:f) nil item)) 25 | 26 | ;;; Note: This is intentionally not a Unicode-friendly case inversion. 27 | ;;; This is a case inversion that is compatible with the upcasing done 28 | ;;; by a Common Lisp reader. This is ideally a self-inverse function. 29 | ;;; Respecting Unicode rules would mean, e.g. sigma and final sigma 30 | ;;; would have the same upper case form. 31 | ;;; 32 | ;;; If the assumption is false in the major CL implementations, then 33 | ;;; more complicated logic would need to be done. 34 | (define-function (%invert-case :inline t :return character) ((character character)) 35 | " 36 | Inverts the case of a character in a CL-compatible way rather than in 37 | a Unicode-proper way. 38 | " 39 | (cond ((upper-case-p character) (char-downcase character)) 40 | ((lower-case-p character) (char-upcase character)) 41 | (t character))) 42 | 43 | (define-function (invert-case :return simple-string) ((simple-string simple-string)) 44 | " 45 | Inverts the case of a string, representing a symbol name, for maximum 46 | CL interoperability. Source code is typically written in lower case 47 | and in CL that is typically then upper-cased, so inverting the case 48 | will allow case sensitivity in Scheme while still keeping the symbols 49 | in a form that CL expects. 50 | " 51 | (map 'simple-string 52 | #'%invert-case 53 | simple-string)) 54 | 55 | (define-function (scheme-symbol-name :inline t) ((symbol symbol)) 56 | "Interns a Scheme symbol using one package, with its case inverted." 57 | (invert-case (symbol-name symbol))) 58 | 59 | (define-function (scheme-symbol :inline t) ((string simple-string)) 60 | "Interns a Scheme symbol using one package, with its case inverted." 61 | (intern (invert-case string) '#:r7rs)) 62 | 63 | (defun coerce-subseq (sequence result-type &optional start end) 64 | "Coerces a subsequence into the result type" 65 | (let ((subseq (if start 66 | (subseq sequence start end) 67 | sequence))) 68 | (coerce subseq result-type))) 69 | 70 | (defun copy-seq-or-subseq (sequence &optional start end) 71 | "Either copies a subsequence or a sequence" 72 | (if start 73 | (subseq sequence start end) 74 | (copy-seq sequence))) 75 | 76 | (define-function (skip-read-char :inline t) (stream) 77 | "Call this when the result is to be ignored." 78 | (read-char stream nil nil t)) 79 | 80 | (define-function (peek-char* :inline t) (stream) 81 | "A simplified version of `peek-char' for the Scheme reader." 82 | (peek-char nil stream nil :eof)) 83 | --------------------------------------------------------------------------------