├── .travis.yml ├── LICENSE ├── Makefile ├── NEWS.md ├── README.md ├── bone.c ├── bone.h ├── boneposix.c ├── boneposix.h ├── core.bn ├── gendoc.bn ├── logo.png ├── main.c ├── posix.bn ├── posixprelude.bn ├── prelude.bn ├── std ├── alist.bn ├── bases.bn ├── bench.bn ├── html.bn ├── log.bn ├── math.bn ├── prog-arg.bn ├── random.bn └── tap.bn └── tests ├── base.bn ├── bench.bn ├── html.bn ├── math.bn ├── posix.bn └── prog-arg.bn /.travis.yml: -------------------------------------------------------------------------------- 1 | os: 2 | - linux 3 | 4 | language: c 5 | 6 | compiler: 7 | - gcc 8 | - clang 9 | 10 | sudo: false 11 | 12 | script: 13 | - make 14 | - make test 15 | 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | /* LICENSE -- The Bone Lisp interpreter. 2 | * 3 | * ISC License 4 | * 5 | * Copyright (C) 2016 Wolfgang Jaehrling 6 | * 7 | * Permission to use, copy, modify, and/or distribute this software for any 8 | * purpose with or without fee is hereby granted, provided that the above 9 | * copyright notice and this permission notice appear in all copies. 10 | * 11 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 12 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 13 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 14 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 15 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 16 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 17 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 18 | */ 19 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | COMPILE_FLAGS=-std=gnu99 -Wall -W -Wextra -Wno-unused -Wno-unused-parameter 2 | FLAGS=-g 3 | #FLAGS=-g -pg 4 | #FLAGS=-O3 5 | 6 | EXTRA_MODULES=boneposix.o 7 | 8 | MODULES=bone.o main.o $(EXTRA_MODULES) 9 | 10 | %.o: %.c bone.h 11 | $(CC) $(FLAGS) $(COMPILE_FLAGS) -c $< -o $@ 12 | 13 | bone: $(MODULES) 14 | $(CC) $(FLAGS) $(MODULES) -lm -o bone 15 | 16 | clean: 17 | rm -f bone *.o 18 | 19 | test: bone 20 | prove -e ./bone tests/*.bn 21 | 22 | docs: bone 23 | ./bone gendoc.bn -i core.bn prelude.bn posix.bn posixprelude.bn std/*.bn 24 | mkdir -p doc/std 25 | for f in index.md *.bn.md std/*.bn.md; do markdown "$$f" >"doc/`echo $$f | sed 's/.md$$/.html/'`"; done 26 | rm index.md; find . -name '*.bn.md' | xargs rm 27 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # Release information 2 | 3 | ## 0.5.0 4 | 5 | * Support for floating point numbers. 6 | * Basic Unicode support: 7 | I/O is done in UTF-8. 8 | * New builtin subs/macros: 9 | `acond` 10 | `caar?` 11 | `caar*` 12 | `cadr?` 13 | `cadr*` 14 | `case` 15 | `cdar?` 16 | `cdar*` 17 | `cddr?` 18 | `cddr*` 19 | `last` 20 | `read-line` 21 | `str*` 22 | `str-ascii-lower` 23 | `str-pad` 24 | `str-padr` 25 | `str-pos?` 26 | `str-select` 27 | `with-dst` 28 | `with-gensyms` 29 | `with-src` 30 | `with-stderr` 31 | `with-stdin` 32 | `with-stdout` 33 | * New standard library module `std/prog-args` for parsing program arguments. 34 | It contains the subs: 35 | `parse-prog-args` 36 | `say-prog-args-help` 37 | * New standard library module `std/log` for logging. 38 | It contains the subs/macros: 39 | `log` 40 | `with-log` 41 | * `(lisp-info 'posix)` returns `0` if POSIX module is used (`#f` otherwise). 42 | * New POSIX bindings: 43 | `call` 44 | `exec` 45 | `str-now` 46 | `sys.ctime?` 47 | `sys.execvp?` 48 | `system` 49 | `wait-for` 50 | * All internal structures are resized dynamically, so there are no arbitrary limits anymore. 51 | * The interpreter takes up less permanent memory space. 52 | * The documentation generator understands basic command line options now. 53 | 54 | ## 0.4.0 55 | 56 | * New standard library module `std/tap` which implements incomplete, but TAP-conformant testing. 57 | It contains the subs/macros: 58 | `test` 59 | `test-error` 60 | `test-plan` 61 | `test-plan-end` 62 | * Show origin of anonymous subs in backtrace. 63 | * `if` allows an else-branch of arbitrary size; 64 | when the `else` branch is empty but would be taken, `#f` is returned. 65 | * Extended fixnum range from 32 to 60 bits. 66 | * Allow mutual recursion: You can `declare` a binding before you define it. 67 | * The stack size is now increased dynamically, so there is no arbitrary limit anymore. 68 | * New reader macro in `std/alist`: 69 | `#=>` allows convenient notation for association lists. 70 | * Introduced a (limited) destructuring binding construct: `destructure`; 71 | it can only destructure proper lists currently (without nesting). 72 | * New builtin subs: 73 | `all?` 74 | `any?` 75 | `car*` 76 | `cdr*` 77 | `chr-skip` 78 | `dup` 79 | `find?` 80 | `flatten` 81 | `partial` 82 | `str-join` 83 | * New POSIX bindings: 84 | `gettimeofday` 85 | `sys.gettimeofday?` 86 | `timeofday-diff` 87 | * New module `std/bench` with subs: 88 | `measure-time` 89 | `say-time` 90 | * New subs in `std/math`: 91 | `count` 92 | `iota` 93 | `iota*` 94 | * `mapx` was removed - it was more confusing than helpful. 95 | * `each` got the order of args reversed to be consistent with everything else. 96 | 97 | ## 0.3.0 98 | 99 | * Support for I/O: 100 | Read from `*src*`. 101 | Print to `*dst*`. 102 | Also define `*stdin*`, `*stdout*` and `*stderr*`. 103 | Provide macros: 104 | `with-file-dst` 105 | `with-file-src` 106 | `with-stderr` 107 | * You can specify a script file on the command line; 108 | you can also use Unix `#!` notation to specify the interpreter in the file. 109 | (If a file starts with `#`, the first line is ignored.) 110 | * Added the documentation generator `gendoc.bn`. 111 | * The reader macro `#eval` allows read-time evaluation. 112 | * New builtin subs and macs: 113 | `awhen` 114 | `drop` 115 | `dropr` 116 | `dst?` 117 | `eof?` 118 | `num->str` 119 | `sort` 120 | `src?` 121 | `str-dropr` 122 | `str-empty?` 123 | `str-prefix?` 124 | `str-take` 125 | `str-taker` 126 | `sym->str` 127 | `take` 128 | `taker` 129 | * New POSIX bindings: 130 | `sys.dst-close?` 131 | `sys.dst-open?` 132 | `sys.random` 133 | `sys.src-close?` 134 | `sys.src-open?` 135 | * New standard library module `std/random` containing: 136 | `random-choice` 137 | * New standard library module `std/bases` containing the reader macros: 138 | `#bin` 139 | `#oct` 140 | `#hex` 141 | `#in-base` 142 | * New standard library module `std/alist` containing: 143 | `simplify-alist` 144 | * Moved these subs from prelude to new standard library module `std/math`: 145 | `max` 146 | `min` 147 | `percent` 148 | * Module `std/math` additionally contains: 149 | `abs` 150 | `difference` 151 | `even?` 152 | `iota` 153 | `mean` 154 | `odd?` 155 | `sum` 156 | * Read access to dynamically scoped variables is faster as it avoids the hash table lookup. 157 | Write access is also faster as it only does a single lookup. 158 | * Show line numbers on parse errors. 159 | 160 | ## 0.2.0 161 | 162 | * Dynamic scoping is now possible via `defvar` and `with-var`. 163 | * Reader macros can be registered with `defreader` or `myreader`. 164 | * You can code character constants with the reader macro `#chr`. 165 | * Errors now just bring you back to the REPL like they should. 166 | * The previous values on the REPL are available via `$` and `$$`. 167 | * You can access the command line args via `*program-args*`. 168 | * Load code from source files with `(use file1 file2 ...)`; 169 | the file extension `.bn` will be added automatically. 170 | Reload files with `(reload foo)`. 171 | * Possibly endless loops that won't run out of memory can be implemented with `reg-loop`. 172 | * You can do recursive definitions not only with `defsub`, but also with the other binding constructs: 173 | `mysub`, `internsub`, `defmac`, `mymac` and `internmac` 174 | * All of the above binding constructs allow to avoid the implicit lambda (as in Scheme). 175 | So you can say: `(mysub atom? (compose not cons?))` 176 | * New library subs: 177 | `0?` 178 | `>0?` 179 | `<0?` 180 | `assocar?` 181 | `car?` 182 | `cat-lists` 183 | `cdr?` 184 | `compose` 185 | `chr-look` 186 | `chr-read` 187 | `equal?` 188 | `err` 189 | `fold` 190 | `foldr` 191 | `lisp-info` 192 | `max` 193 | `min` 194 | `percent` 195 | `read` 196 | `reader-bound?` 197 | `unfold` 198 | `unfoldr` 199 | `var-bound?` 200 | `version` 201 | * Changed argument order of `nth` and `nth-cons`. 202 | * Replaced `str-skip` with `str-drop`. 203 | 204 | ## 0.1.0 205 | 206 | * Initial release 207 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Bone Lisp](logo.png) 2 | 3 | # The Bone Lisp programming language 4 | 5 | Note: This software seems to work pretty well, but it's neither full-featured nor battle-tested, so it should be considered beta-quality. 6 | Furthermore, it will probably stay there forever as I have moved on to work on other projects. 7 | If you are interested in researching the approach of combining explicit regions and immutability, don't hesitate to contact me if you want to know what I would do differently today compared to what I did here. 8 | 9 | (defsub (len xs) 10 | "Calculate the length of the list `xs`." 11 | (with loop (lambda (remain n) 12 | (if (nil? remain) 13 | n 14 | (loop (cdr remain) (++ n)))) 15 | (loop xs 0))) 16 | 17 | ## What? 18 | 19 | Bone is an interpreter for a lexically scoped Lisp-1. 20 | It is based on immutable values and does tail-call elimination. 21 | The special feature that distinguishes it from other Lisps is the *semi-automatic memory management*: 22 | It uses explicit regions instead of garbage collection. 23 | 24 | It is inspired by Pico Lisp, R5RS Scheme, Forth, Common Lisp and Ruby. 25 | 26 | It is written for 64 bit systems and runs on GNU/Linux, 27 | though it should also work on other Unices (with minimal porting). 28 | 29 | *Note: If you were looking for the great [Bones Scheme Compiler](http://www.call-with-current-continuation.org/bones/), that's a different project.* 30 | 31 | ## Why? 32 | 33 | Garbage collection is not a solved problem. 34 | It becomes extremely complex if you want to support multi-threading, avoid pause-times and handle large heaps well. 35 | But doing manual memory management is time-consuming for the programmer - and usually also error-prone. 36 | Explicit regions are both very simple and very fast, but how far can one get with them? 37 | I want to find out, so I am developing this interpreter. 38 | 39 | A language like Bone Lisp could maybe become useful for soft real-time systems (e.g. as a scripting language for games), some kinds of multi-threaded servers and maybe even embedded systems with enough memory. 40 | 41 | ## Status 42 | 43 | [![Build Status](https://travis-ci.org/wolfgangj/bone-lisp.svg?branch=master)](https://travis-ci.org/wolfgangj/bone-lisp) 44 | 45 | ### What it does 46 | 47 | * Lexical scoping & closures 48 | * Optional dynamic scoping 49 | * Tail call elimination 50 | * Explicit regions memory management 51 | * Lists, symbols, strings, fixnums, floats 52 | * Classic Lisp Macros 53 | * Reader macros 54 | * I/O streams with UTF-8 support 55 | * TAS conforming testing library 56 | * POSIX bindings (but not many yet...) 57 | 58 | ### What it does not 59 | 60 | * Multithreading (did not get around to implementing it) 61 | * Networking (likewise) 62 | 63 | * Arrays 64 | (don't fit too well into Bone) 65 | * Hash tables 66 | (we have an implementation anyway, but same as for arrays applies) 67 | * Exceptions 68 | * Module system 69 | (our current hyper-static environment might be good enough) 70 | * Bignums 71 | * Records / structures 72 | * Keywords 73 | (they are nice, but make things more complex) 74 | * Cross-cutting concerns 75 | (probably very useful for the memory region stuff) 76 | 77 | * Garbage collection 78 | (obviously, since the whole point of Bone Lisp is to avoid it) 79 | * Continuations 80 | (I don't think they make sense with explicit regions) 81 | * Being compatible to other Lisp dialects 82 | * Object oriented programming 83 | (creating a good object system is hard and thus takes a lot of time I'd rather spend on other features) 84 | 85 | ## Getting started 86 | 87 | To make embedding as easy as possible, the whole interpreter is in a single C file. 88 | Optional modules have their own C files (currently only `boneposix.c` for the POSIX bindings). 89 | The `main` function is in `main.c`; 90 | it just initializes everything and calls the REPL. 91 | You can compile it all with `make`. 92 | 93 | ## Quick Intro 94 | 95 | Bone Lisp doesn't try to be an overly innovative Lisp (like e.g. Clojure), nor does it try hard to be compatible with tradition. 96 | I hope you'll like the few things Bone does different than traditional Lisps. 97 | 98 | One important piece of terminology is changed: 99 | Keeping with the times, we reserve the term "function" for pure functions without side-effects. 100 | Since Bone Lisp allows some side-effects (like I/O), we mostly speak about using subroutines in our code. 101 | Usually, we abbreviate "subroutine" as "sub", like it is done in modern BASIC dialects. 102 | 103 | To the usual syntactic sugar (like `'x` for quoting) we only add a shortcut for subs with a single expression in the body: 104 | 105 | | a b c (foo) ; => (lambda (a b c) (foo)) 106 | 107 | We use this only for one-liners, though. 108 | 109 | Rest arguments work like they do in Scheme: 110 | 111 | (lambda args foo) 112 | (lambda (a b c . args) foo) 113 | 114 | Booleans and the empty list work almost like they do in Scheme: 115 | 116 | * The empty list is written as `()` and is self-evaluating (whereas in Scheme it can't be evaluated). 117 | * While we still call the empty list "nil", it is not the symbol `nil` (which isn't special in any way). 118 | * You cannot take the `car` and `cdr` of the empty list. 119 | * Only the value `#f` is false. 120 | * The canonical value for true is `#t`. 121 | 122 | The names of predicates end with a question mark (e.g. `nil?`). 123 | Subs which may return a useful value or `#f` (false) also follow this convention (eg. `assoc?`). 124 | This helps to prevent forgetting about the possbility of returning `#f`. 125 | 126 | Most names in the library are taken from Scheme and Common Lisp. 127 | Often, we provide several names for the same thing (like Ruby does). 128 | For example, `len`, `length` and `size` are the same. 129 | See `core.bn` for docstrings describing the builtins. 130 | (We also have `gendoc.bn`, which extracts the docstrings from a source file and generates a markdown file from them. 131 | But this needs improvement.) 132 | 133 | A subroutine can be defined with `defsub`; note that the docstring is required! 134 | 135 | (defsub (sum xs) 136 | "Add all numbers in `xs`." 137 | (apply + xs)) 138 | 139 | (sum '(1 2 3)) ; => 6 140 | 141 | For local helper subs you can use `mysub`, which does not require a docstring and introduces a binding that may be overwritten later. 142 | Note that the environment is hyperstatic (as in Forth): 143 | If you redefine something, the subs previously defined will continue to use the old definition. 144 | 145 | Quasiquoting works as usual, so you can define macros (with `defmac` or `mymac`): 146 | 147 | (defmac (when expr . body) 148 | "Evaluate all of `body` if `expr` is true." 149 | `(if ,expr (do ,@body))) 150 | 151 | The primitive form that introduces a (single) new binding - which may be recusive as in Schemes `letrec` - is `with`: 152 | 153 | (with loop | xs (if (nil? xs) 154 | 0 155 | (++ (loop (cdr xs)))) 156 | (loop '(a b c d))) 157 | ;; => 4 158 | 159 | `let` is simply defined as a macro that expands to nested `with`s. 160 | Therefore it works like a combination of traditional `let*` and `letrec`. 161 | 162 | Dynamic scope can be used by defining a variable first with `defvar`. 163 | Then you can set it for the dynamic extent of some expressions with `with-var`: 164 | 165 | (defvar *depth* 0) 166 | (with-var *depth* (++ *depth*) 167 | (list *depth*)) 168 | ;; => (1) 169 | 170 | *depth* 171 | ;; => 0 172 | 173 | The use of regions is available via: 174 | 175 | (in-reg expr1 expr2 ...) 176 | 177 | The given `expr`s will be evaluated with objects allocated in a new region. 178 | The return value (of the last `expr`) will be copied to the previous region. 179 | Finally, the new region will be freed. 180 | 181 | A source file should declare which version of Bone Lisp it was written for: 182 | 183 | (version 0 4) ; for v0.4.x 184 | 185 | There is no real module system, but you can load files with: 186 | 187 | (use foo) 188 | 189 | This will load `foo.bn`. 190 | Each file will be loaded only once. 191 | Recursive loading will be detected and reported as an error. 192 | 193 | There's much more, but currently you'll have to look into the source code. 194 | If you don't understand something, feel free to ask. 195 | 196 | ## License 197 | 198 | This is Free Software distributed under the terms of the ISC license. 199 | (A very simple non-copyleft license.) 200 | See the file LICENSE for details. 201 | 202 | ## Who? 203 | 204 | It is being developed by 205 | Wolfgang Jaehrling (wolfgang at conseptizer dot org) 206 | 207 | ## Links 208 | 209 | Bone Lisp is influenced by: 210 | * [PicoLisp](http://picolisp.com/) is a pragmatic but simple Lisp 211 | * [R5RS Scheme](http://www.schemers.org/Documents/Standards/R5RS/) is a beautiful Lisp dialect 212 | * [Forth](https://en.wikipedia.org/wiki/Forth_%28programming_language%29) is a deep lesson in simplicity 213 | * [Common Lisp](https://common-lisp.net/) is a full-featured traditional Lisp 214 | * [Ruby](https://www.ruby-lang.org/) is a scripting language with great usability 215 | 216 | Somewhat related Free Software projects: 217 | * [Pre-Scheme](https://en.wikipedia.org/wiki/PreScheme) is a GC-free (LIFO) subset of Scheme 218 | * [Carp](https://github.com/eriksvedang/Carp) is "a statically typed lisp, without a GC" 219 | * [newLISP](http://www.newlisp.org/) uses "One Reference Only" memory management 220 | * [MLKit](http://www.elsman.com/mlkit/) uses region inference (and a GC) 221 | * [Linear Lisp](http://home.pipeline.com/~hbaker1/LinearLisp.html) produces no garbage 222 | * [Dale](https://github.com/tomhrr/dale) is basically C in S-Exprs (but with macros) 223 | * [ThinLisp](http://www.thinlisp.org/) is a subset of Common Lisp that can be used without GC 224 | -------------------------------------------------------------------------------- /bone.c: -------------------------------------------------------------------------------- 1 | /* bone.c -- The Bone Lisp interpreter. 2 | * Copyright (C) 2016 Wolfgang Jaehrling 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #define _GNU_SOURCE 1 // for mmap()s MAP_ANONYMOUS 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #ifndef MAP_ANONYMOUS 30 | #define MAP_ANONYMOUS MAP_ANON 31 | #endif 32 | 33 | #include "bone.h" 34 | 35 | my any last_value; // FIXME: thread-local 36 | my bool silence_errors = false; // FIXME: thread-local? 37 | 38 | my void eprintf(const char *fmt, ...) { 39 | if(!silence_errors) { 40 | va_list args; 41 | va_start(args, fmt); 42 | vfprintf(stderr, fmt, args); 43 | va_end(args); 44 | } 45 | } 46 | 47 | //my void eprint(any); my any L(any x) { eprint(x); puts(""); return x; } // for debugging 48 | my void fail(const char *msg) { 49 | eprintf("%s\n", msg); 50 | exit(1); 51 | } 52 | 53 | my size_t bytes2words(size_t n) { return (n - 1) / sizeof(any) + 1; } 54 | 55 | my const char *type_name(type_tag tag) { 56 | switch (tag) { 57 | case t_cons: return "cons"; 58 | case t_sym: return "sym"; 59 | case t_str: return "str"; 60 | case t_sub: return "sub"; 61 | case t_num: return "num"; 62 | case t_other: default: abort(); // never called with t_other 63 | } 64 | } 65 | 66 | #define HASH_SLOT_UNUSED UNIQ(100) 67 | #define HASH_SLOT_DELETED UNIQ(101) 68 | #define READER_LIST_END UNIQ(102) 69 | #define BINDING_DEFINED UNIQ(103) 70 | #define BINDING_EXISTS UNIQ(104) 71 | #define BINDING_DECLARED UNIQ(105) 72 | bool is_nil(any x) { return x == NIL; } 73 | bool is(any x) { return x != BFALSE; } 74 | any to_bool(bool x) { return x ? BTRUE : BFALSE; } 75 | 76 | my void eprint(any x); 77 | my void backtrace(); 78 | 79 | my void basic_error(const char *fmt, ...) { 80 | if(!silence_errors) { 81 | eprintf("ERR: "); 82 | va_list args; 83 | va_start(args, fmt); 84 | vfprintf(stderr, fmt, args); 85 | va_end(args); 86 | eprintf("\n"); 87 | backtrace(); 88 | } 89 | throw(); 90 | } 91 | 92 | my void generic_error(const char *msg, any x) { 93 | eprintf("ERR: %s: ", msg); 94 | eprint(x); 95 | eprintf("\n"); 96 | backtrace(); 97 | throw(); 98 | } 99 | 100 | my void type_error(any x, type_tag t) { 101 | eprintf("ERR: typecheck failed: (%s? ", type_name(t)); 102 | eprint(x); 103 | eprintf(")\n"); 104 | backtrace(); 105 | throw(); 106 | } 107 | 108 | my type_tag tag_of(any x) { return x & 7; } 109 | my bool is_tagged(any x, type_tag t) { return tag_of(x) == t; } 110 | 111 | void check(any x, type_tag t) { 112 | if(!is_tagged(x, t)) 113 | type_error(x, t); 114 | } 115 | 116 | my any tag(any x, type_tag t) { return x | t; } 117 | my any untag(any x) { return x & ~7; } 118 | 119 | my any untag_check(any x, type_tag t) { 120 | check(x, t); 121 | return untag(x); 122 | } 123 | 124 | type_other_tag get_other_type(any x) { 125 | any *p = (any *)untag_check(x, t_other); 126 | return p[0]; 127 | } 128 | 129 | my bool is_num(any x) { return is_tagged(x, t_num); } 130 | 131 | my type_num_tag get_num_type(any x) { 132 | check(x, t_num); 133 | return (x >> 3) & 1; 134 | } 135 | 136 | int64_t any2int(any x) { 137 | if(get_num_type(x) != t_num_int) 138 | generic_error("ERR: expected integer type", x); 139 | #if (-1 >> 1) == -1 /* Does bit shifting preserve the sign? */ 140 | return (int64_t)x >> 4; 141 | #else 142 | return ((int64_t)x < 0) 143 | ? (~((~((int64_t)x)) >> 4)) /* Negate before and after */ 144 | : ((int64_t)x >> 4); 145 | #endif 146 | } 147 | 148 | any int2any(int64_t n) { 149 | if(n < BONE_INT_MIN || n > BONE_INT_MAX) 150 | basic_error("ERR: integer out of allowed range: %" PRId64, n); 151 | return tag((n << 4) | (t_num_int << 3), t_num); 152 | } 153 | 154 | typedef union { 155 | float f; 156 | uint32_t ui32; 157 | } float_or_uint32; 158 | 159 | float any2float(any x) { 160 | if(get_num_type(x) != t_num_float) 161 | generic_error("ERR: expected float type", x); 162 | float_or_uint32 u; 163 | u.ui32 = ((uint64_t)x) >> 32; 164 | return u.f; 165 | } 166 | 167 | any float2any(float f) { 168 | float_or_uint32 u; 169 | u.f = f; 170 | any r = t_num | (t_num_float << 3) | (((uint64_t)u.ui32) << 32); 171 | return r; 172 | } 173 | 174 | my float anynum2float(any x) { 175 | switch (get_num_type(x)) { 176 | case t_num_int: return (float)any2int(x); 177 | case t_num_float: return any2float(x); 178 | default: abort(); 179 | } 180 | } 181 | 182 | //////////////// regions //////////////// 183 | 184 | #define ALLOC_BLOCKS_AT_ONCE 16 185 | my size_t blocksize; // in bytes 186 | my size_t blockwords; // words per block 187 | my any blockmask; // to get the block an `any` belongs to; is not actually an object! 188 | my any **free_block; 189 | // A block begins with a pointer to the previous block that belongs to the region. 190 | // The metadata of a region (i.e. this struct) is stored in its first block. 191 | typedef struct reg { any **current_block, **allocp; } *reg; 192 | 193 | // This code is in FORTH-style. 194 | my any **block(any *x) { return (any **)(blockmask & (any)x); } // get ptr to start of block that x belongs to. 195 | my any **blocks_alloc(int n) { return mmap(NULL, blocksize * n, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); } 196 | my void block_point_to_next(any **p, int i) { p[i * blockwords] = (any *)&p[(i + 1) * blockwords]; } 197 | my void blocks_init(any **p, int n) { n--; for(int i = 0; i < n; i++) block_point_to_next(p, i); p[n * blockwords] = NULL; } 198 | my any **fresh_blocks() { any **p = blocks_alloc(ALLOC_BLOCKS_AT_ONCE); blocks_init(p, ALLOC_BLOCKS_AT_ONCE); return p; } 199 | my void ensure_free_block() { if(!free_block) free_block = fresh_blocks(); } 200 | my any **block_new(any **next) { ensure_free_block(); any **r = free_block; free_block = (any **)r[0]; r[0] = (any *)next; return r; } 201 | my void reg_init(reg r, any **b) { r->current_block = b; r->allocp = (any **)&r[1]; } 202 | my reg reg_new() { any **b = block_new(NULL); reg r = (reg)&b[1]; reg_init(r, b); return r; } 203 | my void reg_free(reg r) { block((any *)r)[0] = (any *)free_block; free_block = r->current_block; } 204 | my void blocks_sysfree(any **b) { if(!b) return; any **next = (any **)b[0]; munmap(b, blocksize); blocks_sysfree(next); } 205 | my void reg_sysfree(reg r) { blocks_sysfree(r->current_block); } 206 | 207 | my reg permanent_reg; // FIXME: thread-local 208 | my reg *reg_stack; 209 | my int reg_pos, reg_allocated; 210 | my any **allocp, **current_block; // from currently used reg. 211 | my void load_reg(reg r) { allocp = r->allocp; current_block = r->current_block; } 212 | my void store_reg(reg r) { r->allocp = allocp; r->current_block = current_block; } 213 | my void inc_regs() { 214 | if(reg_pos == reg_allocated) { 215 | reg_allocated *= 2; 216 | reg_stack = realloc(reg_stack, reg_allocated * sizeof(struct reg)); 217 | } 218 | reg_pos++; 219 | } 220 | #define curr_reg reg_stack[reg_pos] 221 | my void reg_push(reg r) { store_reg(curr_reg); inc_regs(); curr_reg = r; load_reg(curr_reg); } 222 | my reg reg_pop() { store_reg(curr_reg); reg r = curr_reg; reg_pos--; load_reg(curr_reg); return r; } 223 | #undef curr_reg 224 | my void reg_permanent() { reg_push(permanent_reg); } 225 | 226 | my void in_reg() { reg_push(reg_new()); } 227 | my void end_in_reg() { reg_free(reg_pop()); } 228 | 229 | my void rollback_reg_sp(int pos) { 230 | while(pos != reg_pos) 231 | reg_free(reg_pop()); 232 | } 233 | 234 | any *reg_alloc(int n) { 235 | any *res = (any *)allocp; 236 | allocp += n; 237 | if(block((any *)allocp) == current_block) 238 | return res; // normal case 239 | current_block = block_new(current_block); 240 | allocp = (any **)¤t_block[1]; 241 | return reg_alloc(n); 242 | } 243 | 244 | my any copy(any x); 245 | 246 | my any copy_back(any x) { 247 | reg_push(reg_stack[reg_pos-1]); 248 | any y = copy(x); 249 | reg_pop(); 250 | return y; 251 | } 252 | 253 | //////////////// exceptions //////////////// 254 | 255 | // FIXME: thread-local 256 | my struct exc_buf { 257 | jmp_buf buf; 258 | int reg_pos; 259 | } *exc_bufs; 260 | 261 | my int exc_num; 262 | my int exc_allocated; 263 | 264 | jmp_buf *begin_try_() { 265 | if(exc_allocated == exc_num) { 266 | exc_allocated *= 2; 267 | exc_bufs = realloc(exc_bufs, exc_allocated * sizeof(struct exc_buf)); 268 | } 269 | exc_bufs[exc_num].reg_pos = reg_pos; 270 | return &exc_bufs[exc_num++].buf; 271 | } 272 | 273 | my void exc_buf_nonempty() { 274 | if(!exc_num) 275 | fail("internal error: throw/catch mismatch"); 276 | } 277 | 278 | jmp_buf *throw_() { 279 | exc_buf_nonempty(); 280 | exc_num--; 281 | rollback_reg_sp(exc_bufs[exc_num].reg_pos); 282 | return &exc_bufs[exc_num].buf; 283 | } 284 | 285 | void end_try_() { 286 | exc_buf_nonempty(); 287 | exc_num--; 288 | } 289 | 290 | //////////////// conses / lists //////////////// 291 | 292 | // no tag() needed as t_cons==0 293 | any cons(any a, any d) { 294 | any *p = reg_alloc(2); 295 | p[0] = a; 296 | p[1] = d; 297 | return (any)p; 298 | } 299 | 300 | any far(any x) { return ((any *)x)[0]; } // fast, no typecheck 301 | any fdr(any x) { return ((any *)x)[1]; } // likewise 302 | 303 | any car(any x) { 304 | check(x, t_cons); 305 | return far(x); 306 | } 307 | 308 | any cdr(any x) { 309 | check(x, t_cons); 310 | return fdr(x); 311 | } 312 | 313 | void set_far(any cell, any x) { ((any *)cell)[0] = x; } 314 | void set_fdr(any cell, any x) { ((any *)cell)[1] = x; } 315 | 316 | bool is_cons(any x) { return is_tagged(x, t_cons); } 317 | bool is_single(any x) { return is_cons(x) && is_nil(fdr(x)); } 318 | any single(any x) { return cons(x, NIL); } 319 | any list2(any a, any b) { return cons(a, single(b)); } 320 | any list3(any a, any b, any c) { return cons(a, cons(b, single(c))); } 321 | 322 | my any pcons(any a, any d) { 323 | reg_permanent(); 324 | any res = cons(a, d); 325 | reg_pop(); 326 | return res; 327 | } 328 | 329 | my any pcopy(any x) { 330 | reg_permanent(); 331 | any res = copy(x); 332 | reg_pop(); 333 | return res; 334 | } 335 | 336 | listgen listgen_new() { listgen res = {NIL, NIL}; return res; } 337 | 338 | void listgen_add(listgen *lg, any x) { 339 | if(is_nil(lg->xs)) 340 | lg->xs = lg->last = single(x); 341 | else { 342 | any new = single(x); 343 | set_fdr(lg->last, new); 344 | lg->last = new; 345 | } 346 | } 347 | 348 | my void listgen_add_list(listgen *lg, any xs) { 349 | foreach(x, xs) 350 | listgen_add(lg, x); 351 | } 352 | 353 | my void listgen_set_tail(listgen *lg, any x) { 354 | if(is_nil(lg->xs)) 355 | lg->xs = lg->last = x; 356 | else 357 | set_fdr(lg->last, x); 358 | } 359 | 360 | my any duplist(any xs) { 361 | listgen lg = listgen_new(); 362 | listgen_add_list(&lg, xs); 363 | return lg.xs; 364 | } 365 | 366 | int64_t len(any x) { 367 | int64_t n = 0; 368 | foreach_cons(e, x) n++; 369 | return n; 370 | } 371 | 372 | my any reverse(any xs) { 373 | any res = NIL; 374 | foreach(x, xs) 375 | res = cons(x, res); 376 | return res; 377 | } 378 | 379 | my bool is_member(any a, any xs) { 380 | foreach(x, xs) 381 | if(x == a) 382 | return true; 383 | return false; 384 | } 385 | 386 | my any assoc(any obj, any xs) { 387 | foreach(x, xs) 388 | if(car(x) == obj) 389 | return fdr(x); 390 | return BFALSE; 391 | } 392 | 393 | my any assoc_entry(any obj, any xs) { 394 | foreach(x, xs) 395 | if(car(x) == obj) 396 | return x; 397 | return BFALSE; 398 | } 399 | 400 | my any cat2(any a, any b) { 401 | if(is_nil(a)) 402 | return b; 403 | listgen lg = listgen_new(); 404 | foreach(x, a) 405 | listgen_add(&lg, x); 406 | listgen_set_tail(&lg, b); 407 | return lg.xs; 408 | } 409 | 410 | my any move_last_to_rest_x(any xs) { 411 | if(is_single(xs)) 412 | return far(xs); 413 | foreach_cons(pair, xs) 414 | if(is_single(fdr(pair))) { 415 | set_fdr(pair, far(fdr(pair))); 416 | break; 417 | } 418 | return xs; 419 | } 420 | 421 | my any merge_sort(any bigger_p, any hd) { 422 | if(is_nil(hd)) 423 | return NIL; 424 | hd = duplist(hd); 425 | int64_t area = 1; // size of a part we currently process 426 | while(1) { 427 | any p = hd; 428 | hd = NIL; 429 | any tl = NIL; 430 | int64_t merge_cnt = 0; 431 | while(!is_nil(p)) { 432 | merge_cnt++; 433 | any q = p; 434 | int64_t len_of_p = 0; 435 | for(int64_t i = 0; i < area; i++) { 436 | len_of_p++; 437 | q = fdr(q); 438 | if(is_nil(q)) 439 | break; 440 | } 441 | int64_t len_of_q = area; 442 | while(len_of_p > 0 || (len_of_q > 0 && !is_nil(q))) { 443 | // determine source of next element: 444 | bool from_p; 445 | if(len_of_p == 0) 446 | from_p = false; 447 | else if(len_of_q == 0 || is_nil(q)) 448 | from_p = true; 449 | else { 450 | call2(bigger_p, far(p), far(q)); 451 | from_p = !is(last_value); 452 | } 453 | any e; 454 | if(from_p) { 455 | len_of_p--; 456 | e = p; 457 | p = fdr(p); 458 | } else { 459 | len_of_q--; 460 | e = q; 461 | q = fdr(q); 462 | } 463 | if(!is_nil(tl)) 464 | set_fdr(tl, e); 465 | else 466 | hd = e; 467 | tl = e; 468 | } 469 | p = q; 470 | } 471 | set_fdr(tl, NIL); 472 | if(merge_cnt <= 1) 473 | return hd; 474 | area *= 2; 475 | } 476 | } 477 | 478 | my bool is_zero(any x) { 479 | switch (get_num_type(x)) { 480 | case t_num_int: return any2int(x) == 0; 481 | case t_num_float: return any2float(x) == 0.0; 482 | default: abort(); 483 | } 484 | } 485 | 486 | //////////////// strs //////////////// 487 | 488 | bool is_str(any x) { return is_tagged(x, t_str); } 489 | 490 | my any str(any chrs) { 491 | any *p = reg_alloc(1); 492 | *p = chrs; 493 | return tag((any)p, t_str); 494 | } 495 | 496 | my any unstr(any s) { return *(any *)untag_check(s, t_str); } 497 | 498 | // FIXME: for short strings only 499 | my any charp2list(const char *p) { 500 | return !*p ? NIL : cons(int2any(*p), charp2list(p + 1)); 501 | } 502 | 503 | any charp2str(const char *p) { return str(charp2list(p)); } 504 | 505 | my char *list2charp(any x) { 506 | char *res = malloc(len(x)*4 + 1); // maximum length for UTF-8 507 | char *p = res; 508 | try { 509 | foreach(c, x) { 510 | *p = any2int(c); 511 | p++; 512 | } 513 | } catch { 514 | free(res); 515 | throw(); 516 | } 517 | *p = '\0'; 518 | return res; 519 | } 520 | 521 | char *str2charp(any x) { return list2charp(unstr(x)); } 522 | 523 | my bool str_eql(any s1, any s2) { 524 | s1 = unstr(s1); 525 | s2 = unstr(s2); 526 | foreach(chr, s1) { 527 | if(is_nil(s2) || chr != far(s2)) 528 | return false; 529 | s2 = fdr(s2); 530 | } 531 | return is_nil(s2); 532 | } 533 | 534 | my any num2str(any n) { 535 | char buf[32]; 536 | switch (get_num_type(n)) { 537 | case t_num_int: snprintf(buf, sizeof(buf), "%" PRId64, any2int(n)); break; 538 | case t_num_float: snprintf(buf, sizeof(buf), "%g", (double)any2float(n)); break; 539 | default: abort(); 540 | } 541 | return charp2str(buf); 542 | } 543 | 544 | //////////////// hash tables //////////////// 545 | 546 | #define MAXLOAD 175 // value between 0 and 255 547 | typedef struct hash { 548 | size_t size, taken_slots; 549 | any *keys, *vals; 550 | any default_value; 551 | } *hash; 552 | 553 | my hash hash_new(size_t initsize, any default_val) { 554 | hash h = malloc(sizeof(*h)); 555 | h->size = initsize; 556 | h->taken_slots = 0; 557 | h->default_value = default_val; 558 | h->keys = malloc(initsize * sizeof(any)); 559 | h->vals = malloc(initsize * sizeof(any)); 560 | for(size_t i = 0; i != initsize; i++) 561 | h->keys[i] = HASH_SLOT_UNUSED; 562 | return h; 563 | } 564 | 565 | my void hash_free(hash h) { 566 | free(h->keys); 567 | free(h->vals); 568 | free(h); 569 | } 570 | 571 | /* Find the entry in H with KEY and provide the entry number in *POS. 572 | Return true if there is an entry with this key already. If there 573 | is none, *POS will contain the position of the slot we can use to 574 | add it. */ 575 | my bool find_slot(hash h, any key, size_t *pos) { 576 | bool found_deleted = false; 577 | size_t first_deleted = 0; 578 | *pos = key % h->size; 579 | while(1) { 580 | if(h->keys[*pos] == key) 581 | return true; 582 | if(h->keys[*pos] == HASH_SLOT_UNUSED) { 583 | if(found_deleted) 584 | *pos = first_deleted; 585 | return false; 586 | } 587 | if(h->keys[*pos] == HASH_SLOT_DELETED) { 588 | if(!found_deleted) { 589 | found_deleted = true; 590 | first_deleted = *pos; 591 | } 592 | } 593 | if(++(*pos) == h->size) 594 | *pos = 0; 595 | } 596 | } 597 | 598 | my void hash_set(hash h, any key, any val); 599 | 600 | my bool slot_used(any x) { 601 | return x != HASH_SLOT_UNUSED && x != HASH_SLOT_DELETED; 602 | } 603 | 604 | my void enlarge_table(hash h) { 605 | hash new = hash_new(h->size * 2 + 1, NIL); 606 | for(size_t i = 0; i != h->size; i++) 607 | if(slot_used(h->keys[i])) 608 | hash_set(new, h->keys[i], h->vals[i]); 609 | free(h->keys); 610 | free(h->vals); 611 | h->size = new->size; 612 | h->keys = new->keys; 613 | h->vals = new->vals; 614 | free(new); 615 | } 616 | 617 | my void hash_set(hash h, any key, any val) { 618 | size_t pos; 619 | if(!find_slot(h, key, &pos)) { // adding a new entry 620 | h->taken_slots++; 621 | if(((h->taken_slots << 8) / h->size) > MAXLOAD) { 622 | enlarge_table(h); 623 | find_slot(h, key, &pos); 624 | } 625 | } 626 | h->keys[pos] = key; 627 | h->vals[pos] = val; 628 | } 629 | 630 | my any hash_get(hash h, any key) { 631 | size_t pos; 632 | return find_slot(h, key, &pos) ? h->vals[pos] : h->default_value; 633 | } 634 | 635 | my void hash_rm(hash h, any key) { 636 | size_t pos; 637 | if(find_slot(h, key, &pos)) { 638 | h->keys[pos] = HASH_SLOT_DELETED; 639 | h->taken_slots--; 640 | } 641 | } 642 | 643 | #if 0 // FIXME: hash_iter 644 | my void hash_each(hash h, hash_iter fn, void *hook) { 645 | for(size_t i = 0; i != h->size; i++) 646 | if(slot_used(h->keys[i])) fn(hook, h->keys[i], h->vals[i]); 647 | } 648 | my void hash_print(hash h) { // useful for debugging 649 | for(size_t i = 0; i != h->size; i++) 650 | if(slot_used(h->keys[i])) { 651 | print(h->keys[i]); bputc(':'); print(h->vals[i]); bputc('\n'); 652 | } 653 | } 654 | #endif 655 | 656 | //////////////// syms //////////////// 657 | 658 | my bool is_sym(any x) { return is_tagged(x, t_sym); } 659 | my hash sym_ht; 660 | my any string_hash(const char *s, size_t *len) { // This is the djb2 algorithm. 661 | int32_t hash = 5381; 662 | *len = 0; 663 | while(*s) { 664 | (*len)++; 665 | hash = ((hash << 5) + hash) + *(s++); 666 | } 667 | return int2any(hash); 668 | } 669 | char *symtext(any sym) { return (char *)untag_check(sym, t_sym); } 670 | 671 | // `name` must be interned 672 | my any as_sym(char *name) { 673 | return tag((any)name, t_sym); 674 | } 675 | 676 | my any add_sym(const char *name, size_t len, any id) { 677 | reg_permanent(); 678 | char *new = (char *)reg_alloc(bytes2words(len + 1)); 679 | reg_pop(); 680 | memcpy(new, name, len + 1); 681 | hash_set(sym_ht, id, (any) new); 682 | return as_sym(new); 683 | } 684 | 685 | any intern(const char *name) { 686 | size_t len; 687 | any id = string_hash(name, &len); 688 | while(1) { 689 | char *candidate = (char *)hash_get(sym_ht, id); 690 | if(candidate == NULL) 691 | return add_sym(name, len, id); 692 | if(!strcmp(candidate, name)) 693 | return as_sym(candidate); 694 | id++; 695 | } 696 | } 697 | 698 | my any intern_from_chars(any chrs) { 699 | char *s = list2charp(chrs); 700 | any res = intern(s); 701 | free(s); 702 | return res; 703 | } 704 | 705 | my any gensym() { 706 | static int gensyms = 0; // FIXME: multiple threads? 707 | reg_permanent(); 708 | char *new = (char *)reg_alloc(1); 709 | reg_pop(); 710 | snprintf(new, sizeof(any), "_g%05d", gensyms++); 711 | return as_sym(new); 712 | } 713 | 714 | my any sym2str(any sym) { return charp2str(symtext(sym)); } 715 | 716 | my any s_quote, s_quasiquote, s_unquote, s_unquote_splicing, s_lambda, s_with, 717 | s_if, s_list, s_cat, s_dot, s_do, s_arg, s_env; 718 | #define x(name) s_##name = intern(#name) 719 | my void init_syms() { 720 | x(quote); x(quasiquote); x(unquote); s_unquote_splicing = intern("unquote-splicing"); 721 | x(lambda); x(with); x(if); x(do); x(list); x(cat); s_dot = intern("."); 722 | x(arg); x(env); 723 | } 724 | #undef x 725 | 726 | //////////////// subs //////////////// 727 | 728 | typedef struct sub_code { // fields are in the order in which we access them. 729 | int argc; // number of required args 730 | int take_rest; // accepting rest args? 0=no, 1=yes 731 | int extra_localc; // the ones introduced by `with` 732 | any name; // sym for backtraces 733 | int size_of_env; // so that we can copy subs 734 | any ops[1]; // can be longer 735 | } *sub_code; 736 | 737 | my char *sub_allocp; 738 | my size_t sub_alloc_left; // in bytes! 739 | 740 | my void ensure_sub_alloc(size_t size) { 741 | if(size > sub_alloc_left) { 742 | int additional_blocks = size / blocksize; // to allow extremely large subs 743 | int blocks = ALLOC_BLOCKS_AT_ONCE + additional_blocks; 744 | sub_allocp = (char*)blocks_alloc(blocks); 745 | sub_alloc_left = blocks * blocksize; 746 | } 747 | } 748 | 749 | my sub_code sub_alloc(size_t codeword_cnt) { 750 | size_t size = (codeword_cnt-1)*sizeof(any) + sizeof(struct sub_code); 751 | ensure_sub_alloc(size); 752 | sub_code res = (sub_code)sub_allocp; 753 | sub_allocp += size; 754 | sub_alloc_left -= size; 755 | return res; 756 | } 757 | 758 | my sub_code make_sub_code(int argc, int take_rest, int extra_localc, int size_of_env, int code_size) { 759 | sub_code code = sub_alloc(code_size); 760 | code->argc = argc; 761 | code->take_rest = take_rest; 762 | code->extra_localc = extra_localc; 763 | code->size_of_env = size_of_env; 764 | code->name = BFALSE; 765 | return code; 766 | } 767 | 768 | my int count_locals(sub_code sc) { 769 | return sc->argc + sc->take_rest + sc->extra_localc; 770 | } 771 | 772 | typedef struct sub { 773 | sub_code code; 774 | any env[0]; 775 | } *sub; 776 | 777 | my bool is_sub(any x) { return is_tagged(x, t_sub); } 778 | my any sub2any(sub s) { return tag((any)s, t_sub); } 779 | my sub any2sub(any x) { return (sub)untag_check(x, t_sub); } 780 | 781 | my any copy_sub(any x) { 782 | sub s = any2sub(x); 783 | int envsize = s->code->size_of_env; 784 | any *p = reg_alloc(1 + envsize); 785 | any res = tag((any)p, t_sub); 786 | *p++ = (any)s->code; 787 | for(int i = 0; i != envsize; i++) 788 | *p++ = s->env[i] == x ? res : copy(s->env[i]); // allow recursive subs 789 | return res; 790 | } 791 | 792 | my void name_sub(sub subr, any name) { 793 | if(!is(subr->code->name)) 794 | subr->code->name = name; 795 | } 796 | 797 | //////////////// bindings //////////////// 798 | 799 | my any get_dyn_val(any name); 800 | my void check_overwrite(hash namespace, any name) { 801 | any prev = hash_get(namespace, name); 802 | if(is(prev) && far(prev) == BINDING_DEFINED && !is(get_dyn_val(intern("_*allow-overwrites*")))) 803 | generic_error("already defined", name); 804 | } 805 | 806 | my void add_name(hash namespace, any name, bool overwritable, any val) { 807 | check_overwrite(namespace, name); 808 | if(is_sub(val)) 809 | name_sub(any2sub(val), name); 810 | 811 | hash_set(namespace, name, pcons(overwritable ? BINDING_EXISTS : BINDING_DEFINED, pcopy(val))); 812 | } 813 | 814 | my hash bindings; // FIXME: does it need mutex protection? -> yes, but we use it only at compile-time anyway 815 | my any get_binding(any name) { return hash_get(bindings, name); } 816 | my void bind(any name, bool overwritable, any subr) { 817 | add_name(bindings, name, overwritable, subr); 818 | } 819 | my bool is_bound(any name) { return get_binding(name) != BFALSE; } 820 | 821 | my void declare_binding(any name) { 822 | check_overwrite(bindings, name); 823 | hash_set(bindings, name, pcons(BINDING_DECLARED, BFALSE)); 824 | } 825 | 826 | my hash macros; // FIXME: needs mutex protection, see above 827 | my void mac_bind(any name, bool overwritable, any subr) { 828 | add_name(macros, name, overwritable, subr); 829 | } 830 | my any get_mac(any name) { return hash_get(macros, name); } 831 | my bool is_mac_bound(any name) { return get_mac(name) != BFALSE; } 832 | 833 | my hash readers; // FIXME: needs mutex protection, see above 834 | my void reader_bind(any name, bool overwritable, any subr) { 835 | add_name(readers, name, overwritable, subr); 836 | } 837 | my any get_reader(any name) { return hash_get(readers, name); } 838 | my bool is_reader_bound(any name) { return get_reader(name) != BFALSE; } 839 | 840 | my hash dynamics; // this is shared by threads, it just contains numbers as values 841 | my any dynamic_vals[256]; // FIXME: thread-local, resize 842 | my int dyn_cnt = 0; 843 | my any get_dyn(any name) { return hash_get(dynamics, name); } 844 | my bool is_dyn_bound(any name) { return is(get_dyn(name)); } 845 | my void check_dyn_bound(any x, any name) { if(!is(x)) generic_error("dynamic var unbound", name); } 846 | 847 | my void set_dyn_val(any name, any x) { 848 | any n = get_dyn(name); 849 | check_dyn_bound(n, name); 850 | 851 | dynamic_vals[any2int(n)] = x; 852 | } 853 | 854 | my void create_dyn(any name, any x) { 855 | if(is_dyn_bound(name) && !is(get_dyn_val(intern("_*allow-overwrites*")))) 856 | generic_error("dynamic var bound twice", name); 857 | 858 | hash_set(dynamics, name, int2any(dyn_cnt)); 859 | dynamic_vals[dyn_cnt] = x; 860 | dyn_cnt++; 861 | } 862 | 863 | my any get_existing_dyn(any name) { 864 | any x = get_dyn(name); 865 | check_dyn_bound(x, name); // if this fails, it's an internal error 866 | return x; 867 | } 868 | 869 | my any get_dyn_val(any name) { 870 | return dynamic_vals[any2int(get_existing_dyn(name))]; 871 | } 872 | 873 | //////////////// UTF-8 //////////////// 874 | 875 | #define BITEST(val, one, zero) ((((val) & one) == one) && ((((val) ^ zero) & zero) == zero)) 876 | 877 | my void invalid_utf8(const char *msg) { basic_error("utf-8 I/O: %s", msg); } 878 | 879 | typedef int (*utf8_reader)(void *hook); 880 | 881 | // read UTF-8 according to RFC 3629. 882 | my int utf8_read(utf8_reader reader, void *hook) { 883 | int val = reader (hook); 884 | if(val == EOF) return val; 885 | if(BITEST(val, 0, 0x80)) return val; // ASCII range 886 | 887 | int how_many_more = 0; 888 | if(BITEST(val, 0xC0, 0x20)) { 889 | val &= 0x1F; // keep only code point relevant bits 890 | how_many_more = 1; 891 | } 892 | else if(BITEST(val, 0xE0, 0x10)) { 893 | val &= 0x0F; // see above 894 | how_many_more = 2; 895 | } 896 | else if(BITEST(val, 0xF0, 0x08)) { 897 | val &= 0x07; // see above 898 | how_many_more = 3; 899 | } 900 | else invalid_utf8("unexpected continuation byte"); 901 | 902 | for(int i = 0; i < how_many_more; i++) { 903 | int next = reader(hook); 904 | if(next == EOF) invalid_utf8("EOF where continuation byte was expected"); 905 | if(!BITEST(next, 0x80, 0x40)) invalid_utf8("missing continuation byte"); 906 | val <<= 6; 907 | val |= (next & 0x3F); 908 | } 909 | 910 | // overlong & out-of-range encodings. 911 | #define not_overlong(min) if(!(val >= (min))) invalid_utf8("overlong encoding is forbidden") 912 | switch (how_many_more) { 913 | case 1: not_overlong(0x80); break; 914 | case 2: not_overlong(0x800); break; 915 | case 3: 916 | not_overlong(0x10000); 917 | if(val >= 0x10FFFF) invalid_utf8("character out of range specified in RFC 3629"); 918 | break; 919 | #undef not_overlong 920 | } 921 | return val; 922 | } 923 | 924 | my int from_strp(const char **sp) { 925 | char c = **sp; 926 | (*sp)++; 927 | return c; 928 | } 929 | 930 | my int utf8from_strp(const char **sp) { 931 | return utf8_read ((utf8_reader) &from_strp, sp); 932 | } 933 | 934 | my int utf8getc(FILE *fp) { 935 | return utf8_read((utf8_reader) &getc, fp); 936 | } 937 | 938 | typedef void (*utf8_writer)(int c, void *hook); 939 | 940 | my void utf8_write(utf8_writer writer, int c, void *hook) 941 | { 942 | #define emit(x) writer(x, hook) 943 | if(c < 0x80) { // ASCII range 944 | emit(c); 945 | return; 946 | } 947 | 948 | // extract and mask. 949 | #define CONT_BYTE(x) (((x) & 0x3F) | 0x80) 950 | if(c < 0x800) { 951 | emit((c >> 6) | 0xC0); 952 | emit(CONT_BYTE(c)); 953 | } 954 | else if(c < 0x10000) { 955 | emit((c >> 12) | 0xE0); 956 | emit(CONT_BYTE(c >> 6)); 957 | emit(CONT_BYTE(c)); 958 | } 959 | else if(c < 0x110000) { 960 | emit((c >> 18) | 0xF0); 961 | emit(CONT_BYTE(c >> 12)); 962 | emit(CONT_BYTE(c >> 6)); 963 | emit(CONT_BYTE(c)); 964 | } 965 | else invalid_utf8("character out of range specified in RFC 3629"); 966 | #undef CONT_BYTE 967 | #undef emit 968 | } 969 | 970 | my void to_strp(int c, char **sp) { 971 | **sp = c; 972 | (*sp)++; 973 | } 974 | 975 | my void utf8to_strp(int c, char **sp) { 976 | utf8_write((utf8_writer)to_strp, c, sp); 977 | } 978 | 979 | my void utf8putc(int c, FILE *fp) { 980 | utf8_write((utf8_writer)putc, c, fp); 981 | } 982 | 983 | //////////////// srcs and dsts //////////////// 984 | 985 | typedef struct io { 986 | type_other_tag t; 987 | FILE *fp; 988 | any name; 989 | int line; 990 | } *io; 991 | 992 | my any fp2any(FILE *fp, type_other_tag t, any name) { 993 | io res = (io)reg_alloc(bytes2words(sizeof(*res))); 994 | res->t = t; 995 | res->fp = fp; 996 | res->name = name; 997 | res->line = 1; 998 | return tag((any)res, t_other); 999 | } 1000 | 1001 | any fp2src(FILE *fp, any name) { return fp2any(fp, t_other_src, name); } 1002 | any fp2dst(FILE *fp, any name) { return fp2any(fp, t_other_dst, name); } 1003 | 1004 | my FILE *any2fp(any x, type_other_tag t) { 1005 | io obj = (io)untag_check(x, t_other); 1006 | if(obj->t != t) 1007 | generic_error("can't perform I/O on", x); // FIXME: better error 1008 | return obj->fp; 1009 | } 1010 | 1011 | FILE *src2fp(any x) { return any2fp(x, t_other_src); } 1012 | FILE *dst2fp(any x) { return any2fp(x, t_other_dst); } 1013 | 1014 | my any get_filename(any x) { 1015 | io obj = (io)untag_check(x, t_other); 1016 | if(obj->t != t_other_src && obj->t != t_other_dst) 1017 | generic_error("expected src or dst", x); // FIXME: better error 1018 | return obj->name; 1019 | } 1020 | 1021 | my any input_line(any x) { 1022 | io obj = (io)untag_check(x, t_other); 1023 | if(obj->t != t_other_src) 1024 | generic_error("expected src", x); // FIXME: better error 1025 | return obj->line; 1026 | } 1027 | 1028 | my any copy_src(any x) { 1029 | io res = (io)reg_alloc(bytes2words(sizeof(*res))); 1030 | res->t = t_other_src; 1031 | res->fp = src2fp(x); 1032 | res->name = get_filename(x); 1033 | res->line = input_line(x); 1034 | return tag((any)res, t_other); 1035 | } 1036 | 1037 | my any copy_dst(any x) { 1038 | return fp2dst(dst2fp(x), copy(get_filename(x))); 1039 | } 1040 | 1041 | my int dyn_src, dyn_dst; 1042 | 1043 | my void bputc(int x) { 1044 | utf8putc(x, dst2fp(dynamic_vals[dyn_dst])); 1045 | } 1046 | 1047 | my void bprintf(const char *fmt, ...) { 1048 | va_list args; 1049 | va_start(args, fmt); 1050 | vfprintf(dst2fp(dynamic_vals[dyn_dst]), fmt, args); 1051 | va_end(args); 1052 | } 1053 | 1054 | my int nextc() { 1055 | io obj = (io)untag(dynamic_vals[dyn_src]); 1056 | int res = utf8getc(src2fp(dynamic_vals[dyn_src])); 1057 | if(res == '\n') 1058 | obj->line++; 1059 | return res; 1060 | } 1061 | 1062 | my int look() { 1063 | FILE *fp = src2fp(dynamic_vals[dyn_src]); 1064 | int res = fgetc(fp); 1065 | ungetc(res, fp); // FIXME: only works for ASCIIs 1066 | return res; 1067 | } 1068 | 1069 | //////////////// printer //////////////// 1070 | 1071 | my void print(any x); 1072 | 1073 | my void print_sub_args(any x) { 1074 | if(!is_cons(x)) { 1075 | if(!is_nil(x)) { 1076 | bprintf(". "); 1077 | print(x); 1078 | bputc(' '); 1079 | } 1080 | return; 1081 | } 1082 | print(far(x)); 1083 | bputc(' '); 1084 | print_sub_args(fdr(x)); 1085 | } 1086 | 1087 | my bool is_arglist(any x) { 1088 | if(is_nil(x) || is_sym(x)) 1089 | return true; 1090 | if(is_cons(x) && is_sym(far(x)) && is_arglist(fdr(x))) 1091 | return true; 1092 | return false; 1093 | } 1094 | 1095 | my void print(any x) { 1096 | switch (tag_of(x)) { 1097 | case t_cons: { 1098 | any a = far(x); 1099 | if(is_sym(a)) { 1100 | if(a == s_quote) { bputc('\''); print(fdr(x)); break; } 1101 | if(a == s_unquote) { bputc(','); print(fdr(x)); break; } 1102 | if(a == s_unquote_splicing) { bprintf(",@"); print(fdr(x)); break; } 1103 | if(a == s_quasiquote && is_cons(fdr(x)) && is_nil(fdr(fdr(x)))) { 1104 | bputc('`'); 1105 | print(far(fdr(x))); 1106 | break; 1107 | } 1108 | if(a == s_lambda && is_cons(fdr(x)) && is_arglist(far(fdr(x))) && is_single(fdr(fdr(x))) && is_cons(far(fdr(fdr(x))))) { 1109 | bprintf("| "); 1110 | print_sub_args(far(fdr(x))); 1111 | print(far(fdr(fdr(x)))); 1112 | break; 1113 | } 1114 | } 1115 | bool first = true; 1116 | bputc('('); 1117 | do { 1118 | if(first) 1119 | first = false; 1120 | else 1121 | bputc(' '); 1122 | print(far(x)); 1123 | x = fdr(x); 1124 | } while(is_tagged(x, t_cons)); 1125 | if(x != NIL) { 1126 | bprintf(" . "); 1127 | print(x); 1128 | } 1129 | bputc(')'); 1130 | break; 1131 | } 1132 | case t_sym: bprintf("%s", symtext(x)); break; 1133 | case t_num: 1134 | switch (get_num_type(x)) { 1135 | case t_num_int: bprintf("%" PRId64, any2int(x)); break; 1136 | case t_num_float: bprintf("%g", (double)any2float(x)); break; 1137 | default: abort(); 1138 | } 1139 | break; 1140 | case t_uniq: 1141 | switch (x) { 1142 | case NIL: bprintf("()"); break; 1143 | case BTRUE: bprintf("#t"); break; 1144 | case BFALSE: bprintf("#f"); break; 1145 | case ENDOFFILE: bprintf("#{eof}"); break; 1146 | default: 1147 | bprintf("#{?}"); 1148 | } 1149 | break; 1150 | case t_str: 1151 | bputc('"'); 1152 | foreach(c, unstr(x)) 1153 | switch (any2int(c)) { 1154 | case '"': bprintf("\\\""); break; 1155 | case '\\': bprintf("\\\\"); break; 1156 | case '\n': bprintf("\\n"); break; 1157 | case '\t': bprintf("\\t"); break; 1158 | default: 1159 | bputc(any2int(c)); 1160 | } 1161 | bputc('"'); 1162 | break; 1163 | case t_sub: 1164 | bprintf("#sub(id=%p name=", (void *)x); 1165 | sub_code code = any2sub(x)->code; 1166 | print(code->name); 1167 | bprintf(" argc=%d take-rest?=", code->argc); 1168 | print(code->take_rest ? BTRUE : BFALSE); 1169 | bputc(')'); 1170 | break; 1171 | case t_other: 1172 | switch(get_other_type(x)) { 1173 | case t_other_src: 1174 | bprintf("#{src "); 1175 | print(get_filename(x)); 1176 | bprintf(":%d}", input_line(x)); 1177 | break; 1178 | case t_other_dst: 1179 | bprintf("#{dst "); 1180 | print(get_filename(x)); 1181 | bputc('}'); 1182 | break; 1183 | default: 1184 | abort(); 1185 | } 1186 | break; 1187 | default: 1188 | abort(); 1189 | } 1190 | } 1191 | 1192 | my void say_str(any s) { 1193 | foreach(chr, unstr(s)) 1194 | bputc(any2int(chr)); 1195 | } 1196 | 1197 | my void say(any x) { 1198 | switch (tag_of(x)) { 1199 | case t_str: 1200 | say_str(x); 1201 | break; 1202 | case t_cons: 1203 | foreach(e, x) 1204 | say(e); 1205 | break; 1206 | default: 1207 | print(x); 1208 | } 1209 | } 1210 | 1211 | my void eprint(any x) { 1212 | if(!silence_errors) { 1213 | any old = dynamic_vals[dyn_dst]; 1214 | dynamic_vals[dyn_dst] = get_dyn_val(intern("*stderr*")); 1215 | print(x); 1216 | dynamic_vals[dyn_dst] = old; 1217 | } 1218 | } 1219 | 1220 | //////////////// reader //////////////// 1221 | 1222 | my void parse_error(const char *text) { 1223 | eprint(dynamic_vals[dyn_src]); 1224 | eprintf(": parse error: %s\n", text); 1225 | throw(); 1226 | } 1227 | 1228 | // These can be used for syms in s-exprs 1229 | // Disallowed are the first 32 and "#'(),@:;[]`{}| 1230 | my bool allowed_chars[] = { 1231 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 1232 | 0,1,0,0,1,1,1,0,0,0,1,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,1,1,1,1, 1233 | 0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,0,1,1, 1234 | 0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,1,0 1235 | }; 1236 | 1237 | my bool is_symchar(int c) { 1238 | return (c >= 0 && c < 256) ? allowed_chars[c] : c != EOF; 1239 | } 1240 | 1241 | my void skip_until(char end) { 1242 | int c; 1243 | do 1244 | c = nextc(); 1245 | while(c != end && c != EOF); 1246 | } 1247 | 1248 | my int find_token() { 1249 | while(1) { 1250 | int c = nextc(); 1251 | switch (c) { 1252 | case ';': 1253 | skip_until('\n'); 1254 | break; 1255 | case ' ': 1256 | case '\t': 1257 | case '\n': 1258 | case '\f': 1259 | case '\r': 1260 | break; 1261 | default: 1262 | return c; 1263 | } 1264 | } 1265 | } 1266 | 1267 | my int digit2int(any chr) { 1268 | int dig = any2int(chr) - '0'; 1269 | return (dig >= 0 && dig <= 9) ? dig : -1; 1270 | } 1271 | 1272 | my any chars2num(any chrs) { 1273 | int64_t ires = 0; 1274 | int pos = 0, decimal_point_pos = -1; 1275 | bool is_positive = true, is_num = false; // need `is_num` to catch "", ".", "+" and "-" 1276 | foreach (chr, chrs) { 1277 | int dig = digit2int(chr); 1278 | pos++; 1279 | if(dig == -1) { 1280 | if(pos == 1 && any2int(chr) == '-') { 1281 | is_positive = false; 1282 | continue; 1283 | } 1284 | if(pos == 1 && any2int(chr) == '+') 1285 | continue; 1286 | if(decimal_point_pos == -1 && any2int(chr) == '.') { 1287 | decimal_point_pos = pos; 1288 | continue; 1289 | } 1290 | return BFALSE; 1291 | } 1292 | is_num = true; 1293 | ires *= 10; 1294 | ires += dig; 1295 | } 1296 | if(is_num) 1297 | if(decimal_point_pos < 0) 1298 | return int2any(is_positive ? ires : -ires); 1299 | else { 1300 | float f = is_positive ? ires : -ires; 1301 | for(; decimal_point_pos < pos; decimal_point_pos++) 1302 | f /= 10.0; 1303 | return float2any(f); 1304 | } 1305 | else 1306 | return BFALSE; 1307 | } 1308 | 1309 | my any chars_to_num_or_sym(any cs) { 1310 | any num = chars2num(cs); 1311 | return is(num) ? num : intern_from_chars(cs); 1312 | } 1313 | 1314 | my any read_sym_chars(int start_char) { 1315 | listgen lg = listgen_new(); 1316 | listgen_add(&lg, int2any(start_char)); 1317 | int c; 1318 | while(is_symchar(c = look())) 1319 | listgen_add(&lg, int2any(nextc())); 1320 | return lg.xs; 1321 | } 1322 | 1323 | my any read_str() { 1324 | listgen lg = listgen_new(); 1325 | while(1) { 1326 | int c = nextc(); 1327 | if(c == '"') 1328 | return str(lg.xs); 1329 | if(c == EOF) 1330 | parse_error("end of file inside of a str"); 1331 | if(c == '\\') 1332 | switch (c = nextc()) { 1333 | case '\\': case '"': break; 1334 | case 'n': c = '\n'; break; 1335 | case 't': c = '\t'; break; 1336 | case EOF: 1337 | parse_error("end of file after backslash in str"); 1338 | default: 1339 | parse_error("invalid character after backslash in str"); 1340 | } 1341 | listgen_add(&lg, int2any(c)); 1342 | } 1343 | } 1344 | 1345 | my any reader(); // for mutual recursion 1346 | 1347 | my any read_list() { 1348 | any x = reader(); 1349 | if(x == READER_LIST_END) 1350 | return NIL; 1351 | if(x == ENDOFFILE) 1352 | parse_error("end of file in list (use `M-x check-parens`)"); 1353 | if(x == s_dot) { 1354 | x = reader(); 1355 | if(reader() != READER_LIST_END) 1356 | parse_error("invalid improper list"); 1357 | return x; 1358 | } 1359 | return cons(x, read_list()); 1360 | } 1361 | 1362 | my any short_lambda_parser(any *body) { 1363 | any x = reader(); 1364 | if(is_cons(x)) { 1365 | *body = x; 1366 | return NIL; 1367 | } 1368 | if(!is_sym(x)) 1369 | parse_error("invalid lambda short form (expected argument or body)"); 1370 | if(x == s_dot) { 1371 | any rest = reader(); 1372 | *body = reader(); 1373 | return rest; 1374 | } 1375 | return cons(x, short_lambda_parser(body)); 1376 | } 1377 | 1378 | my any read_lambda_short_form() { 1379 | any body, args = short_lambda_parser(&body); 1380 | return list3(s_lambda, args, body); 1381 | } 1382 | 1383 | my any read_unquote() { 1384 | any q = s_unquote; 1385 | int c = look(); 1386 | if(c == '@') { 1387 | nextc(); 1388 | q = s_unquote_splicing; 1389 | } 1390 | return cons(q, reader()); 1391 | } 1392 | 1393 | my any reader() { 1394 | int c = find_token(); 1395 | switch (c) { 1396 | case ')': return READER_LIST_END; 1397 | case '(': return read_list(); 1398 | case '|': return read_lambda_short_form(); 1399 | case '\'': return cons(s_quote, reader()); 1400 | case '`': return cons(s_quasiquote, single(reader())); 1401 | case ',': return read_unquote(); 1402 | case '"': return read_str(); 1403 | case '#': { 1404 | any which = reader(); 1405 | if(!is_sym(which)) 1406 | parse_error("not a sym after #"); 1407 | any query = get_reader(which); 1408 | if(!is(query)) 1409 | parse_error("unknown reader requested"); 1410 | call0(fdr(query)); 1411 | return last_value; 1412 | } 1413 | case EOF: 1414 | return ENDOFFILE; 1415 | default: 1416 | return (chars_to_num_or_sym(read_sym_chars(c))); 1417 | } 1418 | } 1419 | 1420 | my any bone_read() { 1421 | any x = reader(); 1422 | if(x == READER_LIST_END) 1423 | parse_error("unexpected closing parenthesis (use `M-x check-parens`)"); 1424 | return x; 1425 | } 1426 | 1427 | //////////////// evaluator //////////////// 1428 | 1429 | typedef enum { 1430 | OP_CONST = 1, 1431 | OP_GET_ENV, 1432 | OP_GET_ARG, 1433 | OP_SET_LOCAL, 1434 | OP_WRAP, 1435 | OP_PREPARE_CALL, 1436 | OP_PREPARE_DIRECT_CALL, 1437 | OP_CALL, 1438 | OP_TAILCALL, 1439 | OP_ADD_ARG, 1440 | OP_ADD_NONREST_ARG, 1441 | OP_ADD_FIRST_REST_ARG, 1442 | OP_ADD_ANOTHER_REST_ARG, 1443 | OP_JMP_IFN, 1444 | OP_JMP, 1445 | OP_RET, 1446 | OP_PREPARE_SUB, 1447 | OP_ADD_ENV, 1448 | OP_MAKE_SUB_NAMED, 1449 | OP_MAKE_SUB, 1450 | OP_MAKE_RECURSIVE, 1451 | OP_DYN, 1452 | OP_INSERT_DECLARED 1453 | } opcode; 1454 | 1455 | void bone_result(any x) { last_value = x; } 1456 | my any *locals_stack = NULL; // FIXME: thread-local 1457 | my size_t locals_allocated; // FIXME: thread-local 1458 | my size_t locals_pos; // FIXME: thread-local 1459 | 1460 | my size_t alloc_locals(int n) { 1461 | size_t res = locals_pos; 1462 | locals_pos += n; 1463 | if(locals_pos > locals_allocated) { 1464 | locals_allocated *= 2; 1465 | locals_stack = realloc(locals_stack, locals_allocated * sizeof(any)); 1466 | } 1467 | return res; 1468 | } 1469 | 1470 | my void drop_locals(int n) { locals_pos -= n; } 1471 | 1472 | struct call_stack_entry { 1473 | sub subr; 1474 | size_t args_pos; 1475 | int tail_calls; 1476 | } *call_stack; 1477 | my size_t call_stack_allocated; 1478 | my size_t call_stack_pos; 1479 | 1480 | my bool is_self_evaluating(any x) { return !(is_sym(x) || is_cons(x)); } 1481 | 1482 | my void eprint_arg(any x) { 1483 | if(!is_self_evaluating(x)) 1484 | eprintf("'"); 1485 | eprint(x); 1486 | } 1487 | 1488 | my void backtrace() { 1489 | eprintf("BACKTRACE:\n"); 1490 | for(size_t pos = call_stack_pos; pos != 0; pos--) { 1491 | eprintf("("); 1492 | if(is(call_stack[pos].subr->code->name)) 1493 | eprint(call_stack[pos].subr->code->name); 1494 | else 1495 | eprintf(""); 1496 | 1497 | int i; 1498 | for(i = 0; i != call_stack[pos].subr->code->argc; i++) { 1499 | eprintf(" "); 1500 | eprint_arg(locals_stack[call_stack[pos].args_pos + i]); 1501 | } 1502 | if(call_stack[pos].subr->code->take_rest) 1503 | foreach(x, locals_stack[call_stack[pos].args_pos + i]) { 1504 | eprintf(" "); 1505 | eprint_arg(x); 1506 | } 1507 | eprintf(")\n"); 1508 | if(call_stack[pos].tail_calls) 1509 | eprintf(" ;; hidden tail calls: %d\n", call_stack[pos].tail_calls); 1510 | } 1511 | } 1512 | 1513 | struct upcoming_call { 1514 | sub to_be_called; 1515 | int locals_cnt; 1516 | int nonrest_args_left; 1517 | any rest_constructor; 1518 | size_t args_pos, next_arg_pos; 1519 | }; 1520 | my struct upcoming_call *upcoming_calls; 1521 | my size_t upcoming_calls_allocated; 1522 | my size_t next_call_pos; 1523 | my struct upcoming_call *next_call() { return &upcoming_calls[next_call_pos]; } 1524 | my void add_upcoming_call() { 1525 | next_call_pos++; 1526 | if(next_call_pos == upcoming_calls_allocated) { 1527 | upcoming_calls_allocated *= 2; 1528 | upcoming_calls = realloc(upcoming_calls, upcoming_calls_allocated * sizeof(struct upcoming_call)); 1529 | } 1530 | } 1531 | 1532 | my void args_error(sub_code sc, any xs) { 1533 | generic_error("wrong number of args", cons(sc->name, xs)); 1534 | } 1535 | 1536 | my void args_error_unspecific(sub_code sc) { 1537 | args_error(sc, single(intern("..."))); 1538 | } 1539 | 1540 | my void add_nonrest_arg() { locals_stack[next_call()->next_arg_pos++] = last_value; } 1541 | 1542 | my void add_first_rest_arg() { 1543 | sub_code sc = next_call()->to_be_called->code; 1544 | next_call()->rest_constructor = locals_stack[next_call()->args_pos + sc->argc] = single(last_value); 1545 | } 1546 | my void add_another_rest_arg() { 1547 | any next = single(last_value); 1548 | set_fdr(next_call()->rest_constructor, next); 1549 | next_call()->rest_constructor = next; 1550 | } 1551 | my void add_rest_arg() { 1552 | sub_code sc = next_call()->to_be_called->code; 1553 | if(!sc->take_rest) 1554 | args_error_unspecific(sc); 1555 | if(next_call()->rest_constructor == NIL) 1556 | add_first_rest_arg(); 1557 | else 1558 | add_another_rest_arg(); 1559 | } 1560 | 1561 | my void verify_argc(struct upcoming_call *the_call) { 1562 | if(the_call->nonrest_args_left) 1563 | args_error_unspecific(the_call->to_be_called->code); 1564 | } 1565 | 1566 | my void call(sub subr, size_t args_pos, int locals_cnt) { 1567 | sub lambda = NULL; 1568 | any *lambda_envp = NULL; 1569 | call_stack_pos++; 1570 | if(call_stack_pos == call_stack_allocated) { 1571 | call_stack_allocated *= 2; 1572 | call_stack = realloc(call_stack, call_stack_allocated * sizeof(*call_stack)); 1573 | } 1574 | call_stack[call_stack_pos].subr = subr; 1575 | call_stack[call_stack_pos].args_pos = args_pos; 1576 | call_stack[call_stack_pos].tail_calls = 0; 1577 | start:; 1578 | any *env = subr->env; 1579 | any *ip = subr->code->ops; 1580 | while(1) 1581 | switch (*ip++) { 1582 | case OP_CONST: last_value = *ip++; break; 1583 | case OP_GET_ENV: last_value = env[*ip++]; break; 1584 | case OP_GET_ARG: last_value = locals_stack[args_pos + *ip++]; break; // args+locals 1585 | case OP_SET_LOCAL: locals_stack[args_pos + *ip++] = last_value; break; 1586 | case OP_WRAP: ((csub)*ip)(&locals_stack[args_pos]); goto cleanup; 1587 | case OP_PREPARE_CALL: 1588 | last_value = (any)any2sub(last_value); 1589 | // fall through 1590 | case OP_PREPARE_DIRECT_CALL: { 1591 | sub to_be_called = (sub)last_value; 1592 | sub_code sc = to_be_called->code; 1593 | add_upcoming_call(); 1594 | next_call()->to_be_called = to_be_called; 1595 | next_call()->nonrest_args_left = sc->argc; 1596 | next_call()->locals_cnt = count_locals(sc); 1597 | next_call()->next_arg_pos = next_call()->args_pos = alloc_locals(next_call()->locals_cnt); 1598 | if(sc->take_rest) { 1599 | next_call()->rest_constructor = locals_stack[next_call()->args_pos + sc->argc] = NIL; 1600 | } 1601 | break; 1602 | } 1603 | case OP_CALL: { 1604 | struct upcoming_call *the_call = &upcoming_calls[next_call_pos--]; 1605 | verify_argc(the_call); 1606 | call(the_call->to_be_called, the_call->args_pos, the_call->locals_cnt); 1607 | break; 1608 | } 1609 | case OP_TAILCALL: { 1610 | struct upcoming_call *the_call = &upcoming_calls[next_call_pos--]; 1611 | verify_argc(the_call); 1612 | for(int i = 0; i < the_call->locals_cnt; i++) 1613 | locals_stack[args_pos + i] = locals_stack[the_call->args_pos + i]; 1614 | drop_locals(locals_cnt); 1615 | locals_cnt = the_call->locals_cnt; 1616 | subr = the_call->to_be_called; 1617 | call_stack[call_stack_pos].subr = subr; 1618 | call_stack[call_stack_pos].args_pos = args_pos; // FIXME: stays unchanged? 1619 | call_stack[call_stack_pos].tail_calls++; 1620 | goto start; 1621 | } 1622 | case OP_ADD_ARG: 1623 | if(next_call()->nonrest_args_left) { 1624 | next_call()->nonrest_args_left--; 1625 | add_nonrest_arg(); 1626 | } else 1627 | add_rest_arg(); 1628 | break; 1629 | case OP_ADD_NONREST_ARG: 1630 | next_call()->nonrest_args_left--; 1631 | add_nonrest_arg(); 1632 | break; 1633 | case OP_ADD_FIRST_REST_ARG: 1634 | add_first_rest_arg(); 1635 | break; 1636 | case OP_ADD_ANOTHER_REST_ARG: 1637 | add_another_rest_arg(); 1638 | break; 1639 | case OP_JMP_IFN: 1640 | if(is(last_value)) { 1641 | ip++; 1642 | break; 1643 | } // else fall through 1644 | case OP_JMP: 1645 | ip += *ip; 1646 | break; 1647 | case OP_RET: 1648 | goto cleanup; 1649 | case OP_PREPARE_SUB: { 1650 | sub_code lc = (sub_code)*ip++; 1651 | lambda = (sub)reg_alloc(1 + lc->size_of_env); 1652 | lambda->code = lc; 1653 | lambda_envp = lambda->env; 1654 | break; 1655 | } 1656 | case OP_ADD_ENV: 1657 | *(lambda_envp++) = last_value; 1658 | break; 1659 | case OP_MAKE_SUB_NAMED: { 1660 | any parent = call_stack[call_stack_pos].subr->code->name; 1661 | if(is(parent)) { 1662 | char *text = symtext(parent); 1663 | char *name = malloc(strlen(text) + 2); 1664 | name[0] = '@'; 1665 | strcpy(name + 1, text); 1666 | lambda->code->name = intern(name); 1667 | free(name); 1668 | } 1669 | ip[-1] = OP_MAKE_SUB; 1670 | } // fall through 1671 | case OP_MAKE_SUB: 1672 | last_value = sub2any(lambda); 1673 | break; 1674 | case OP_MAKE_RECURSIVE: 1675 | any2sub(last_value)->env[0] = last_value; 1676 | break; 1677 | case OP_DYN: 1678 | last_value = dynamic_vals[*ip++]; 1679 | break; 1680 | case OP_INSERT_DECLARED: { 1681 | any binding = get_binding(*ip); 1682 | if(far(binding) == BINDING_DECLARED) 1683 | generic_error("binding declared, but not defined before use", *ip); 1684 | ip[-1] = OP_CONST; 1685 | last_value = ip[0] = fdr(binding); 1686 | ip++; 1687 | break; 1688 | } 1689 | default: 1690 | eprintf("unknown vm instruction\n"); 1691 | abort(); // FIXME 1692 | } 1693 | cleanup: 1694 | call_stack_pos--; 1695 | drop_locals(locals_cnt); 1696 | } 1697 | 1698 | my void apply(any s, any xs) { 1699 | sub subr = any2sub(s); 1700 | sub_code sc = subr->code; 1701 | int argc = sc->argc, pos = 0; 1702 | int locals_cnt = count_locals(sc); 1703 | size_t args_pos = alloc_locals(locals_cnt); 1704 | any *args = &locals_stack[args_pos]; 1705 | listgen lg; 1706 | foreach(x, xs) { 1707 | if(pos < argc) { 1708 | args[pos] = x; 1709 | pos++; 1710 | continue; 1711 | } // non-rest arg 1712 | if(pos == argc) { 1713 | // starting rest args 1714 | if(!sc->take_rest) 1715 | args_error(sc, xs); 1716 | lg = listgen_new(); 1717 | listgen_add(&lg, x); 1718 | args[pos] = lg.xs; 1719 | pos++; 1720 | continue; 1721 | } 1722 | // adding another rest arg 1723 | listgen_add(&lg, x); 1724 | pos++; 1725 | } 1726 | if(pos < argc) 1727 | args_error(sc, xs); 1728 | if(pos == argc) 1729 | args[argc] = NIL; 1730 | call(subr, args_pos, locals_cnt); 1731 | } 1732 | 1733 | void call0(any subr) { apply(subr, NIL); } 1734 | 1735 | //void call1(any subr, any x) { apply(subr, single(x)); } 1736 | void call1(any s, any x) { 1737 | sub subr = any2sub(s); 1738 | sub_code sc = subr->code; 1739 | int locals_cnt = count_locals(sc); 1740 | size_t args_pos = alloc_locals(locals_cnt); 1741 | any *args = &locals_stack[args_pos]; 1742 | if(sc->argc == 1) { 1743 | args[0] = x; 1744 | if(sc->take_rest) 1745 | args[1] = NIL; 1746 | } 1747 | else if(sc->argc == 0 && sc->take_rest) 1748 | *args = single(x); 1749 | else 1750 | args_error(sc, single(x)); 1751 | call(subr, args_pos, locals_cnt); 1752 | } 1753 | 1754 | void call2(any subr, any x, any y) { apply(subr, list2(x, y)); } 1755 | 1756 | //////////////// compiler //////////////// 1757 | 1758 | my any mac_expand_1(any x) { 1759 | if(!is_cons(x) || far(x) == s_quote) 1760 | return x; 1761 | if(is_sym(far(x))) { 1762 | any mac = get_mac(far(x)); 1763 | if(is(mac)) { 1764 | apply(fdr(mac), fdr(x)); 1765 | return last_value; 1766 | } 1767 | } 1768 | bool changed = false; 1769 | listgen lg = listgen_new(); 1770 | any lst = x; 1771 | if(far(x) == s_lambda) { 1772 | listgen_add(&lg, s_lambda); 1773 | listgen_add(&lg, car(fdr(x))); 1774 | lst = fdr(fdr(x)); 1775 | } 1776 | foreach(e, lst) { 1777 | any new = mac_expand_1(e); 1778 | if(new != e) 1779 | changed = true; 1780 | listgen_add(&lg, new); 1781 | } 1782 | return changed ? lg.xs : x; 1783 | } 1784 | my any mac_expand(any x) { 1785 | any res; 1786 | while(1) { 1787 | res = mac_expand_1(x); 1788 | if(res == x) 1789 | return res; 1790 | x = res; 1791 | } 1792 | } 1793 | 1794 | typedef struct compile_state { 1795 | any dst; 1796 | int pos; 1797 | int max_locals; 1798 | int curr_locals; 1799 | int extra_offset; 1800 | } compile_state; 1801 | 1802 | my int extra_pos(compile_state *s) { 1803 | return s->curr_locals + s->extra_offset - 1; 1804 | } 1805 | 1806 | my void emit(any x, compile_state *state) { 1807 | any next = single(x); 1808 | set_fdr(state->dst, next); 1809 | state->dst = next; 1810 | state->pos++; 1811 | } 1812 | 1813 | // decl for mutual recursion 1814 | my any compile_expr(any e, any env, bool tail_context, compile_state *state); 1815 | 1816 | my void compile_if(any e, any env, bool tail_context, compile_state *state) { 1817 | compile_expr(car(e), env, false, state); 1818 | e = fdr(e); 1819 | emit(OP_JMP_IFN, state); 1820 | emit(0, state); 1821 | compile_state to_else_jmp = *state; 1822 | 1823 | compile_expr(car(e), env, tail_context, state); 1824 | emit(OP_JMP, state); 1825 | emit(0, state); 1826 | e = fdr(e); 1827 | set_far(to_else_jmp.dst, state->pos + 1 - to_else_jmp.pos); 1828 | compile_state after_then_jmp = *state; 1829 | 1830 | compile_expr(cons(s_do, e), env, tail_context, state); 1831 | set_far(after_then_jmp.dst, state->pos + 1 - after_then_jmp.pos); 1832 | } 1833 | 1834 | my any lambda_ignore_list(any old, any args) { 1835 | listgen lg = listgen_new(); 1836 | if(is_sym(args)) 1837 | listgen_add(&lg, args); // only rest arg 1838 | else 1839 | foreach_cons(x, args) { 1840 | listgen_add(&lg, far(x)); 1841 | if(!is_cons(fdr(x)) && !is_nil(fdr(x))) 1842 | listgen_add(&lg, fdr(x)); 1843 | } 1844 | 1845 | if(is_nil(lg.last)) 1846 | return old; 1847 | set_fdr(lg.last, old); 1848 | return lg.xs; 1849 | } 1850 | 1851 | my void found_local(any local, listgen *lg, int *cnt) { 1852 | if(!is_member(local, lg->xs)) { 1853 | (*cnt)++; 1854 | listgen_add(lg, local); 1855 | } 1856 | } 1857 | 1858 | // `locals` is of the form ((foo arg . 0) (bar arg . 1) (baz env . 0)) 1859 | my void collect_locals_rec(any code, any locals, any ignore, int *cnt, listgen *lg) { 1860 | foreach(x, code) 1861 | switch (tag_of(x)) { 1862 | case t_sym: { 1863 | any local = assoc_entry(x, locals); 1864 | if(is(local) && !is_member(x, ignore)) { 1865 | found_local(far(local), lg, cnt); 1866 | } 1867 | break; 1868 | } 1869 | case t_cons: 1870 | if(far(x) == s_quote) 1871 | continue; 1872 | if(far(x) == s_with) { 1873 | collect_locals_rec(cdr(fdr(x)), locals, cons(car(fdr(x)), ignore), cnt, lg); 1874 | continue; 1875 | } 1876 | if(far(x) == s_lambda) { 1877 | collect_locals_rec(cdr(fdr(x)), locals, lambda_ignore_list(ignore, car(fdr(x))), cnt, lg); 1878 | continue; 1879 | } 1880 | collect_locals_rec(x, locals, ignore, cnt, lg); 1881 | break; 1882 | default:; 1883 | } 1884 | } 1885 | 1886 | my any collect_locals(any code, any locals, any ignore, int *cnt) { 1887 | listgen collected = listgen_new(); 1888 | collect_locals_rec(code, locals, ignore, cnt, &collected); 1889 | listgen res = listgen_new(); 1890 | // keep the original order: 1891 | foreach(candidate, locals) 1892 | if(is_member(far(candidate), collected.xs)) 1893 | listgen_add(&res, candidate); 1894 | return res.xs; 1895 | } 1896 | 1897 | my any add_local(any env, any name, any kind, int num) { 1898 | return cons(cons(name, cons(kind, num)), env); 1899 | } 1900 | 1901 | my any locals_for_lambda(any env, any args) { 1902 | any res = NIL; 1903 | int cnt = 0; 1904 | foreach(x, env) 1905 | res = add_local(res, far(x), s_env, cnt++); 1906 | cnt = 0; 1907 | foreach(x, args) 1908 | res = add_local(res, x, s_arg, cnt++); 1909 | return res; 1910 | } 1911 | 1912 | my any flatten_rest_x(any xs, int *len, int *take_rest) { // stores len w/o rest in `*len`. 1913 | if(is_sym(xs)) { // only rest args 1914 | *take_rest = 1; 1915 | return single(xs); 1916 | } 1917 | foreach_cons(x, xs) { 1918 | (*len)++; 1919 | any tail = fdr(x); 1920 | if(is_sym(tail)) { 1921 | set_fdr(x, single(tail)); 1922 | *take_rest = 1; 1923 | return xs; 1924 | } 1925 | } 1926 | *take_rest = 0; 1927 | return xs; 1928 | } 1929 | 1930 | my sub_code compile2sub_code(any expr, any env, int argc, int take_rest, int env_size); 1931 | 1932 | my void compile_lambda(any args, any body, any env, compile_state *state) { 1933 | int argc = 0, take_rest; 1934 | args = flatten_rest_x(args, &argc, &take_rest); 1935 | int collected_env_len = 0; 1936 | any collected_env = collect_locals(cons(s_do, body), env, args, &collected_env_len); 1937 | any env_of_sub = locals_for_lambda(collected_env, args); 1938 | if(is_nil(body)) 1939 | basic_error("body of lambda expression is empty"); 1940 | sub_code sc = compile2sub_code(cons(s_do, body), env_of_sub, argc, take_rest, collected_env_len); 1941 | emit(OP_PREPARE_SUB, state); 1942 | emit((any)sc, state); 1943 | 1944 | foreach(x, collected_env) { 1945 | any env_or_arg = far(fdr(x)); 1946 | any pos = fdr(fdr(x)); 1947 | 1948 | emit(env_or_arg == s_arg ? OP_GET_ARG : OP_GET_ENV, state); 1949 | emit(pos, state); 1950 | emit(OP_ADD_ENV, state); 1951 | } 1952 | emit(OP_MAKE_SUB_NAMED, state); 1953 | } 1954 | 1955 | my void compile_do(any body, any env, bool tail_context, compile_state *state) { 1956 | foreach_cons(x, body) 1957 | compile_expr(far(x), env, is_nil(fdr(x)) && tail_context, state); 1958 | } 1959 | 1960 | my bool arglist_contains(any args, any name) { 1961 | if(is_nil(args)) 1962 | return false; 1963 | if(is_sym(args)) 1964 | return args == name; 1965 | if(car(args) == name) 1966 | return true; 1967 | return arglist_contains(fdr(args), name); 1968 | } 1969 | 1970 | my bool refers_to(any expr, any name) { 1971 | if(is_sym(expr)) 1972 | return expr == name; 1973 | if(!is_cons(expr)) 1974 | return false; 1975 | if(far(expr) == s_quote) 1976 | return false; 1977 | if(far(expr) == s_with) { 1978 | if(car(fdr(expr)) == name) 1979 | return false; 1980 | return refers_to(fdr(fdr(expr)), name); 1981 | } 1982 | if(far(expr) == s_lambda) { 1983 | if(arglist_contains(car(fdr(expr)), name)) 1984 | return false; 1985 | return refers_to(fdr(fdr(expr)), name); 1986 | } 1987 | 1988 | foreach(x, expr) 1989 | if(refers_to(x, name)) 1990 | return true; 1991 | return false; 1992 | } 1993 | 1994 | my void compile_with(any name, any expr, any body, any env, bool tail_context, compile_state *state) { 1995 | state->curr_locals++; 1996 | if(state->curr_locals > state->max_locals) 1997 | state->max_locals = state->curr_locals; 1998 | 1999 | env = add_local(env, name, s_arg, extra_pos(state)); 2000 | compile_expr(expr, env, false, state); 2001 | emit(OP_SET_LOCAL, state); 2002 | emit(extra_pos(state), state); 2003 | 2004 | if(refers_to(expr, name)) 2005 | emit(OP_MAKE_RECURSIVE, state); 2006 | compile_do(body, env, tail_context, state); 2007 | state->curr_locals--; 2008 | } 2009 | 2010 | // if `e` is a sym that has is bound globally, return the value bound to it; false in all other cases. 2011 | my any compile_expr(any e, any env, bool tail_context, compile_state *state) { 2012 | switch (tag_of(e)) { 2013 | case t_num: 2014 | case t_uniq: 2015 | case t_str: 2016 | case t_sub: 2017 | case t_other: 2018 | emit(OP_CONST, state); 2019 | emit(pcopy(e), state); 2020 | break; 2021 | case t_cons: { 2022 | any first = far(e); 2023 | any rest = fdr(e); 2024 | if(first == s_quote) { 2025 | emit(OP_CONST, state); 2026 | emit(pcopy(rest), state); 2027 | break; 2028 | } 2029 | if(first == s_do) { 2030 | compile_do(rest, env, tail_context, state); 2031 | break; 2032 | } 2033 | if(first == s_if) { 2034 | compile_if(rest, env, tail_context, state); 2035 | break; 2036 | } 2037 | if(first == s_lambda) { 2038 | compile_lambda(car(rest), cdr(rest), env, state); 2039 | break; 2040 | } 2041 | if(first == s_with) { 2042 | compile_with(car(rest), car(cdr(rest)), cdr(cdr(rest)), env, tail_context, state); 2043 | break; 2044 | } 2045 | any known_sub = compile_expr(first, env, false, state); 2046 | if(!is(known_sub)) { 2047 | emit(OP_PREPARE_CALL, state); 2048 | // we don't know which sub it is, so we use the generic ADD_ARG: 2049 | foreach(arg, rest) { 2050 | compile_expr(arg, env, false, state); 2051 | emit(OP_ADD_ARG, state); 2052 | } 2053 | } else { 2054 | set_far(state->dst, (any)any2sub(known_sub)); // fix up 2055 | emit(OP_PREPARE_DIRECT_CALL, state); 2056 | sub_code sc = any2sub(known_sub)->code; 2057 | int argpos_indicator = sc->argc; 2058 | int take_rest = sc->take_rest; 2059 | foreach(arg, rest) { 2060 | if(!take_rest && argpos_indicator == 0) 2061 | args_error_unspecific(sc); 2062 | compile_expr(arg, env, false, state); 2063 | emit(argpos_indicator > 0 ? OP_ADD_NONREST_ARG : (argpos_indicator == 0 ? OP_ADD_FIRST_REST_ARG : OP_ADD_ANOTHER_REST_ARG), 2064 | state); 2065 | argpos_indicator--; 2066 | } 2067 | } 2068 | emit(tail_context ? OP_TAILCALL : OP_CALL, state); 2069 | break; 2070 | } 2071 | case t_sym: { 2072 | any local = assoc(e, env); 2073 | if(is(local)) { 2074 | emit(far(local) == s_arg ? OP_GET_ARG : OP_GET_ENV, state); 2075 | emit(fdr(local), state); 2076 | break; 2077 | } 2078 | any global = get_binding(e); 2079 | if(is_cons(global)) { 2080 | if(far(global) != BINDING_DECLARED) { 2081 | emit(OP_CONST, state); 2082 | emit(fdr(global), state); 2083 | return fdr(global); 2084 | } else { 2085 | emit(OP_INSERT_DECLARED, state); 2086 | emit(e, state); 2087 | } 2088 | break; 2089 | } 2090 | any dyn = get_dyn(e); 2091 | if(is(dyn)) { 2092 | emit(OP_DYN, state); 2093 | emit(any2int(dyn), state); 2094 | break; 2095 | } 2096 | generic_error("unbound sym", e); 2097 | break; 2098 | } 2099 | } 2100 | return BFALSE; 2101 | } 2102 | 2103 | my any compile2list(any expr, any env, int extra_offset, int *extra_locals) { 2104 | any res = single(BFALSE); 2105 | compile_state state = {res, 0, 0, 0, extra_offset}; 2106 | compile_expr(expr, env, true, &state); 2107 | emit(OP_RET, &state); 2108 | *extra_locals = state.max_locals; 2109 | return fdr(res); 2110 | } 2111 | 2112 | my sub_code compile2sub_code(any expr, any env, int argc, int take_rest, int env_size) { 2113 | int extra; 2114 | any raw = compile2list(expr, env, argc + take_rest, &extra); 2115 | sub_code code = make_sub_code(argc, take_rest, extra, env_size, len(raw)); 2116 | any *p = code->ops; 2117 | foreach(x, raw) 2118 | *p++ = x; 2119 | return code; 2120 | } 2121 | 2122 | my sub_code compile_toplevel_expr(any e) { 2123 | sub_code res = compile2sub_code(mac_expand(e), NIL, 0, 0, 0); 2124 | return res; 2125 | } 2126 | 2127 | my void eval_toplevel_expr(any e) { 2128 | sub_code code = compile_toplevel_expr(e); 2129 | call0(sub2any((sub)&code)); 2130 | } 2131 | 2132 | //////////////// quasiquote //////////////// 2133 | 2134 | my any quasiquote(any x); 2135 | 2136 | my any qq_list(any x) { 2137 | if(!is_cons(x)) 2138 | return list2(s_quote, x); 2139 | if(far(x) == s_unquote) 2140 | return list2(s_list, fdr(x)); 2141 | if(far(x) == s_unquote_splicing) 2142 | return fdr(x); 2143 | if(far(x) == s_quasiquote) 2144 | return qq_list(quasiquote(car(fdr(x)))); 2145 | return list2(s_list, list3(s_cat, qq_list(far(x)), quasiquote(fdr(x)))); 2146 | } 2147 | 2148 | my any qq_id(any x) { return !is_sym(x) ? x : cons(s_quote, x); } 2149 | 2150 | my any quasiquote(any x) { 2151 | if(!is_cons(x)) 2152 | return qq_id(x); 2153 | if(far(x) == s_unquote) 2154 | return fdr(x); 2155 | if(far(x) == s_unquote_splicing) 2156 | generic_error("invalid quasiquote form", x); 2157 | if(far(x) == s_quasiquote) 2158 | return quasiquote(quasiquote(car(fdr(x)))); 2159 | return list3(s_cat, qq_list(far(x)), quasiquote(fdr(x))); 2160 | } 2161 | 2162 | //////////////// library //////////////// 2163 | 2164 | DEFSUB(fastplus) { 2165 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2166 | ? int2any(any2int(args[0]) + any2int(args[1])) 2167 | : float2any(anynum2float(args[0]) + anynum2float(args[1])); 2168 | } 2169 | DEFSUB(fullplus) { 2170 | int64_t ires = 0; // as long as we encounter only ints, we operate in "int mode" 2171 | foreach_cons(c, args[0]) { 2172 | any n = far(c); 2173 | switch (get_num_type(n)) { 2174 | case t_num_int: 2175 | ires += any2int(n); 2176 | break; 2177 | case t_num_float: { // switching to "float mode" 2178 | float fres = ires; 2179 | foreach(x, c) 2180 | fres += anynum2float(x); 2181 | last_value = float2any(fres); 2182 | return; // end of code for "float mode" 2183 | } 2184 | default: 2185 | abort(); 2186 | } 2187 | } 2188 | last_value = int2any(ires); 2189 | } 2190 | DEFSUB(cons) { last_value = cons(args[0], args[1]); } 2191 | DEFSUB(print) { 2192 | print(args[0]); 2193 | last_value = single(args[0]); 2194 | } 2195 | DEFSUB(apply) { apply(args[0], move_last_to_rest_x(args[1])); } 2196 | DEFSUB(id) { last_value = args[0]; } 2197 | DEFSUB(nilp) { last_value = to_bool(args[0] == NIL); } 2198 | DEFSUB(eqp) { last_value = to_bool(args[0] == args[1]); } 2199 | DEFSUB(not) { last_value = to_bool(args[0] == BFALSE); } 2200 | DEFSUB(car) { last_value = car(args[0]); } 2201 | DEFSUB(cdr) { last_value = cdr(args[0]); } 2202 | DEFSUB(consp) { last_value = to_bool(is_tagged(args[0], t_cons)); } 2203 | DEFSUB(symp) { last_value = to_bool(is_tagged(args[0], t_sym)); } 2204 | DEFSUB(subp) { last_value = to_bool(is_tagged(args[0], t_sub)); } 2205 | DEFSUB(nump) { last_value = to_bool(is_tagged(args[0], t_num)); } 2206 | DEFSUB(intp) { last_value = to_bool(is_tagged(args[0], t_num) && get_num_type(args[0]) == t_num_int); } 2207 | DEFSUB(floatp) { last_value = to_bool(is_tagged(args[0], t_num) && get_num_type(args[0]) == t_num_float); } 2208 | DEFSUB(round) { 2209 | switch (get_num_type(args[0])) { 2210 | case t_num_int: last_value = args[0]; break; 2211 | case t_num_float: last_value = int2any(llroundf(any2float(args[0]))); break; 2212 | default: abort(); 2213 | } 2214 | } 2215 | DEFSUB(ceil) { 2216 | switch (get_num_type(args[0])) { 2217 | case t_num_int: last_value = args[0]; break; 2218 | case t_num_float: last_value = int2any((int64_t)ceilf(any2float(args[0]))); break; 2219 | default: abort(); 2220 | } 2221 | } 2222 | DEFSUB(floor) { 2223 | switch (get_num_type(args[0])) { 2224 | case t_num_int: last_value = args[0]; break; 2225 | case t_num_float: last_value = int2any((int64_t)floorf(any2float(args[0]))); break; 2226 | default: abort(); 2227 | } 2228 | } 2229 | DEFSUB(trunc) { 2230 | switch (get_num_type(args[0])) { 2231 | case t_num_int: last_value = args[0]; break; 2232 | case t_num_float: last_value = int2any((int64_t)truncf(any2float(args[0]))); break; 2233 | default: abort(); 2234 | } 2235 | } 2236 | DEFSUB(strp) { last_value = to_bool(is_tagged(args[0], t_str)); } 2237 | DEFSUB(str) { last_value = str(args[0]); } 2238 | DEFSUB(unstr) { last_value = unstr(args[0]); } 2239 | DEFSUB(len) { last_value = int2any(len(args[0])); } 2240 | DEFSUB(assoc) { last_value = assoc(args[0], args[1]); } 2241 | DEFSUB(intern) { last_value = intern_from_chars(unstr(args[0])); } 2242 | DEFSUB(copy) { last_value = copy(args[0]); } 2243 | DEFSUB(say) { 2244 | foreach(x, args[0]) 2245 | say(x); 2246 | last_value = BTRUE; 2247 | } 2248 | DEFSUB(fastminus) { 2249 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2250 | ? int2any(any2int(args[0]) - any2int(args[1])) 2251 | : float2any(anynum2float(args[0]) - anynum2float(args[1])); 2252 | } 2253 | DEFSUB(fullminus) { 2254 | CSUB_fullplus(&args[1]); 2255 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(last_value) == t_num_int) 2256 | ? int2any(any2int(args[0]) - any2int(last_value)) 2257 | : float2any(anynum2float(args[0]) - anynum2float(last_value)); 2258 | } 2259 | DEFSUB(fast_num_eqp) { 2260 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2261 | ? to_bool(any2int(args[0]) == any2int(args[1])) 2262 | : to_bool(anynum2float(args[0]) == anynum2float(args[1])); 2263 | } 2264 | DEFSUB(fast_num_neqp) { 2265 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2266 | ? to_bool(any2int(args[0]) != any2int(args[1])) 2267 | : to_bool(anynum2float(args[0]) != anynum2float(args[1])); 2268 | } 2269 | DEFSUB(fast_num_gtp) { 2270 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2271 | ? to_bool(any2int(args[0]) > any2int(args[1])) 2272 | : to_bool(anynum2float(args[0]) > anynum2float(args[1])); 2273 | } 2274 | DEFSUB(fast_num_ltp) { 2275 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2276 | ? to_bool(any2int(args[0]) < any2int(args[1])) 2277 | : to_bool(anynum2float(args[0]) < anynum2float(args[1])); 2278 | } 2279 | DEFSUB(fast_num_geqp) { 2280 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2281 | ? to_bool(any2int(args[0]) >= any2int(args[1])) 2282 | : to_bool(anynum2float(args[0]) >= anynum2float(args[1])); 2283 | } 2284 | DEFSUB(fast_num_leqp) { 2285 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2286 | ? to_bool(any2int(args[0]) <= any2int(args[1])) 2287 | : to_bool(anynum2float(args[0]) <= anynum2float(args[1])); 2288 | } 2289 | DEFSUB(each) { 2290 | check(args[0], t_sub); 2291 | foreach(x, args[1]) 2292 | call1(args[0], x); 2293 | } 2294 | DEFSUB(fastmult) { 2295 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2296 | ? int2any(any2int(args[0]) * any2int(args[1])) 2297 | : float2any(anynum2float(args[0]) * anynum2float(args[1])); 2298 | } 2299 | DEFSUB(fullmult) { 2300 | int64_t ires = 1; // as long as we encounter only ints, we operate in "int mode" 2301 | foreach_cons(c, args[0]) { 2302 | any n = far(c); 2303 | switch (get_num_type(n)) { 2304 | case t_num_int: 2305 | ires *= any2int(n); 2306 | break; 2307 | case t_num_float: { // switching to "float mode" 2308 | float fres = ires; 2309 | foreach(x, c) 2310 | fres *= anynum2float(x); 2311 | last_value = float2any(fres); 2312 | return; // end of code for "float mode" 2313 | } 2314 | default: 2315 | abort(); 2316 | } 2317 | } 2318 | last_value = int2any(ires); 2319 | } 2320 | DEFSUB(fastdiv) { 2321 | if(is_zero(args[1])) 2322 | basic_error("division by zero"); 2323 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(args[1]) == t_num_int) 2324 | ? int2any(any2int(args[0]) / any2int(args[1])) 2325 | : float2any(anynum2float(args[0]) / anynum2float(args[1])); 2326 | } 2327 | DEFSUB(fulldiv) { 2328 | CSUB_fullmult(&args[1]); 2329 | if(is_zero(last_value)) 2330 | basic_error("division by zero"); 2331 | last_value = (get_num_type(args[0]) == t_num_int && get_num_type(last_value) == t_num_int) 2332 | ? int2any(any2int(args[0]) / any2int(last_value)) 2333 | : float2any(anynum2float(args[0]) / anynum2float(last_value)); 2334 | } 2335 | DEFSUB(listp) { last_value = to_bool(is_cons(args[0]) || is_nil(args[0])); } 2336 | DEFSUB(cat2) { last_value = cat2(args[0], args[1]); } 2337 | DEFSUB(in_reg) { 2338 | in_reg(); 2339 | call0(args[0]); 2340 | last_value = copy_back(last_value); 2341 | end_in_reg(); 2342 | } 2343 | DEFSUB(bind) { bind(args[0], is(args[1]), args[2]); } 2344 | DEFSUB(assoc_entry) { last_value = assoc_entry(args[0], args[1]); } 2345 | DEFSUB(str_eql) { last_value = to_bool(str_eql(args[0], args[1])); } 2346 | DEFSUB(str_neql) { last_value = to_bool(!str_eql(args[0], args[1])); } 2347 | DEFSUB(list_star) { last_value = move_last_to_rest_x(args[0]); } 2348 | DEFSUB(memberp) { last_value = to_bool(is_member(args[0], args[1])); } 2349 | DEFSUB(reverse) { last_value = reverse(args[0]); } 2350 | DEFSUB(mod) { last_value = int2any(any2int(args[0]) % any2int(args[1])); } 2351 | DEFSUB(bit_not) { last_value = int2any(~any2int(args[0])); } 2352 | DEFSUB(bit_and) { last_value = int2any(any2int(args[0]) & any2int(args[1])); } 2353 | DEFSUB(bit_or) { last_value = int2any(any2int(args[0]) | any2int(args[1])); } 2354 | DEFSUB(bit_xor) { last_value = int2any(any2int(args[0]) ^ any2int(args[1])); } 2355 | DEFSUB(quasiquote) { last_value = quasiquote(args[0]); } 2356 | DEFSUB(mac_expand_1) { last_value = mac_expand_1(args[0]); } 2357 | DEFSUB(mac_bind) { mac_bind(args[0], is(args[1]), args[2]); } 2358 | DEFSUB(mac_expand) { last_value = mac_expand(args[0]); } 2359 | DEFSUB(boundp) { last_value = to_bool(is_bound(args[0])); } 2360 | DEFSUB(mac_bound_p) { last_value = to_bool(is_mac_bound(args[0])); } 2361 | DEFSUB(eval) { eval_toplevel_expr(args[0]); } 2362 | DEFSUB(gensym) { last_value = gensym(); } 2363 | DEFSUB(map) { 2364 | any s = args[0]; 2365 | check(s, t_sub); 2366 | listgen lg = listgen_new(); 2367 | foreach(x, args[1]) { 2368 | call1(s, x); 2369 | listgen_add(&lg, last_value); 2370 | } 2371 | last_value = lg.xs; 2372 | } 2373 | DEFSUB(filter) { 2374 | any s = args[0]; 2375 | listgen lg = listgen_new(); 2376 | foreach(x, args[1]) { 2377 | call1(s, x); 2378 | if(is(last_value)) 2379 | listgen_add(&lg, x); 2380 | } 2381 | last_value = lg.xs; 2382 | } 2383 | DEFSUB(full_cat) { 2384 | listgen lg = listgen_new(); 2385 | foreach_cons(c, args[0]) if(is_cons(c) && is_nil(fdr(c))) { 2386 | listgen_set_tail(&lg, far(c)); 2387 | break; 2388 | } 2389 | else listgen_add_list(&lg, far(c)); 2390 | last_value = lg.xs; 2391 | } 2392 | DEFSUB(refers_to) { last_value = to_bool(refers_to(args[0], args[1])); } 2393 | DEFSUB(load) { bone_load(symtext(args[0])); } 2394 | DEFSUB(var_bind) { create_dyn(args[0], args[1]); } 2395 | DEFSUB(with_var) { 2396 | int dyn_pos = any2int(get_existing_dyn(args[0])); 2397 | any old = dynamic_vals[dyn_pos]; 2398 | dynamic_vals[dyn_pos] = args[1]; 2399 | 2400 | bool failed = false; 2401 | try { 2402 | call0(args[2]); 2403 | } catch { 2404 | failed = true; 2405 | } 2406 | dynamic_vals[dyn_pos] = old; 2407 | if(failed) 2408 | throw(); 2409 | } 2410 | DEFSUB(var_bound_p) { last_value = to_bool(is_dyn_bound(args[0])); } 2411 | DEFSUB(var_bang) { set_dyn_val(args[0], args[1]); } 2412 | DEFSUB(reg_loop) { 2413 | reg_push(reg_new()); 2414 | call0(args[0]); 2415 | 2416 | while(1) { 2417 | reg old = reg_pop(); 2418 | reg_push(reg_new()); 2419 | any sub_args = copy(last_value); 2420 | reg_free(old); 2421 | apply(args[1], sub_args); 2422 | if(!is(car(last_value))) 2423 | break; 2424 | last_value = fdr(last_value); 2425 | } 2426 | last_value = copy_back(fdr(last_value)); 2427 | reg_free(reg_pop()); 2428 | } 2429 | DEFSUB(err) { 2430 | if(!silence_errors) { 2431 | any old = dynamic_vals[dyn_dst]; 2432 | dynamic_vals[dyn_dst] = get_dyn_val(intern("*stderr*")); 2433 | eprintf("ERR: "); 2434 | say(*args); 2435 | eprintf("\n"); 2436 | dynamic_vals[dyn_dst] = old; 2437 | backtrace(); 2438 | } 2439 | throw(); 2440 | } 2441 | DEFSUB(singlep) { last_value = to_bool(is_single(args[0])); } 2442 | DEFSUB(read) { last_value = bone_read(); } 2443 | DEFSUB(chr_read) { 2444 | int c = nextc(); 2445 | last_value = c != -1 ? int2any(c) : ENDOFFILE; 2446 | } 2447 | DEFSUB(chr_look) { 2448 | int c = look(); 2449 | last_value = c != -1 ? int2any(c) : ENDOFFILE; 2450 | } 2451 | DEFSUB(reader_t) { last_value = BTRUE; } 2452 | DEFSUB(reader_f) { last_value = BFALSE; } 2453 | DEFSUB(reader_bind) { reader_bind(args[0], is(args[1]), args[2]); } 2454 | DEFSUB(reader_bound_p) { last_value = to_bool(is_reader_bound(args[0])); } 2455 | DEFSUB(reload) { 2456 | any old = get_dyn_val(intern("_*allow-overwrites*")); 2457 | set_dyn_val(intern("_*allow-overwrites*"), BTRUE); 2458 | bool failed = false; 2459 | try { 2460 | CSUB_load(args); 2461 | } catch { 2462 | failed = true; 2463 | } 2464 | set_dyn_val(intern("_*allow-overwrites*"), old); 2465 | if(failed) 2466 | throw(); 2467 | } 2468 | DEFSUB(sort) { last_value = merge_sort(args[0], args[1]); } 2469 | DEFSUB(num2str) { last_value = num2str(args[0]); } 2470 | DEFSUB(sym2str) { last_value = sym2str(args[0]); } 2471 | DEFSUB(src_line) { last_value = int2any(input_line(args[0])); } 2472 | DEFSUB(file_name) { last_value = get_filename(args[0]); } 2473 | 2474 | DEFSUB(with_file_src) { 2475 | char *fname = str2charp(args[0]); 2476 | FILE *fp = fopen(fname, "r"); 2477 | free(fname); 2478 | if(!fp) 2479 | generic_error("could not open", args[0]); 2480 | any old = dynamic_vals[dyn_src]; 2481 | dynamic_vals[dyn_src] = fp2src(fp, args[0]); 2482 | 2483 | bool failed = false; 2484 | try { 2485 | call0(args[1]); 2486 | } catch { 2487 | failed = true; 2488 | } 2489 | dynamic_vals[dyn_src] = old; 2490 | fclose(fp); 2491 | if(failed) 2492 | throw(); 2493 | } 2494 | 2495 | DEFSUB(with_file_dst) { 2496 | char *fname = str2charp(args[0]); 2497 | FILE *fp = fopen(fname, "w"); 2498 | free(fname); 2499 | if(!fp) 2500 | generic_error("could not open", args[0]); 2501 | any old = dynamic_vals[dyn_dst]; 2502 | dynamic_vals[dyn_dst] = fp2dst(fp, args[0]); 2503 | 2504 | bool failed = false; 2505 | try { 2506 | call0(args[1]); 2507 | } catch { 2508 | failed = true; 2509 | } 2510 | dynamic_vals[dyn_dst] = old; 2511 | fclose(fp); 2512 | if(failed) 2513 | throw(); 2514 | } 2515 | 2516 | DEFSUB(eofp) { last_value = to_bool(args[0] == ENDOFFILE); } 2517 | DEFSUB(srcp) { last_value = to_bool(tag_of(args[0]) == t_other && *((type_other_tag *)untag(args[0])) == t_other_src); } 2518 | DEFSUB(dstp) { last_value = to_bool(tag_of(args[0]) == t_other && *((type_other_tag *)untag(args[0])) == t_other_dst); } 2519 | 2520 | DEFSUB(declare) { declare_binding(args[0]); } 2521 | 2522 | DEFSUB(protect) { 2523 | bool old = silence_errors; 2524 | silence_errors = true; 2525 | size_t csp_backup = call_stack_pos; 2526 | try { 2527 | call0(args[0]); 2528 | } catch { 2529 | last_value = BFALSE; 2530 | } 2531 | call_stack_pos = csp_backup; 2532 | silence_errors = old; 2533 | } 2534 | 2535 | DEFSUB(dup) { last_value = duplist(args[0]); } 2536 | 2537 | DEFSUB(pcons) { last_value = pcons(args[0], args[1]); } 2538 | 2539 | my any make_csub(csub cptr, int argc, int take_rest) { 2540 | sub_code code = make_sub_code(argc, take_rest, 0, 0, 2); 2541 | code->ops[0] = OP_WRAP; 2542 | code->ops[1] = (any)cptr; 2543 | sub subr = (sub)reg_alloc(1); 2544 | subr->code = code; 2545 | return sub2any(subr); 2546 | } 2547 | 2548 | void bone_register_csub(csub cptr, const char *name, int argc, int take_rest) { 2549 | bind(intern(name), false, make_csub(cptr, argc, take_rest)); 2550 | } 2551 | 2552 | my void register_cmac(csub cptr, const char *name, int argc, int take_rest) { 2553 | mac_bind(intern(name), false, make_csub(cptr, argc, take_rest)); 2554 | } 2555 | 2556 | my void register_creader(csub cptr, const char *name) { 2557 | reader_bind(intern(name), false, make_csub(cptr, 0, 0)); 2558 | } 2559 | 2560 | my void init_csubs() { 2561 | bone_register_csub(CSUB_fastplus, "_fast+", 2, 0); 2562 | bone_register_csub(CSUB_fullplus, "_full+", 0, 1); 2563 | bone_register_csub(CSUB_cons, "cons", 2, 0); 2564 | bone_register_csub(CSUB_print, "print", 1, 0); 2565 | bone_register_csub(CSUB_apply, "apply", 1, 1); 2566 | bone_register_csub(CSUB_id, "id", 1, 0); 2567 | bone_register_csub(CSUB_id, "list", 0, 1); 2568 | bone_register_csub(CSUB_nilp, "nil?", 1, 0); 2569 | bone_register_csub(CSUB_eqp, "eq?", 2, 0); 2570 | bone_register_csub(CSUB_not, "not", 1, 0); 2571 | bone_register_csub(CSUB_car, "car", 1, 0); 2572 | bone_register_csub(CSUB_cdr, "cdr", 1, 0); 2573 | bone_register_csub(CSUB_consp, "cons?", 1, 0); 2574 | bone_register_csub(CSUB_symp, "sym?", 1, 0); 2575 | bone_register_csub(CSUB_subp, "sub?", 1, 0); 2576 | bone_register_csub(CSUB_nump, "num?", 1, 0); 2577 | bone_register_csub(CSUB_intp, "int?", 1, 0); 2578 | bone_register_csub(CSUB_floatp, "float?", 1, 0); 2579 | bone_register_csub(CSUB_round, "round", 1, 0); 2580 | bone_register_csub(CSUB_ceil, "ceil", 1, 0); 2581 | bone_register_csub(CSUB_floor, "floor", 1, 0); 2582 | bone_register_csub(CSUB_trunc, "trunc", 1, 0); 2583 | bone_register_csub(CSUB_strp, "str?", 1, 0); 2584 | bone_register_csub(CSUB_str, "str", 1, 0); 2585 | bone_register_csub(CSUB_unstr, "unstr", 1, 0); 2586 | bone_register_csub(CSUB_len, "len", 1, 0); 2587 | bone_register_csub(CSUB_assoc, "assoc?", 2, 0); 2588 | bone_register_csub(CSUB_intern, "intern", 1, 0); 2589 | bone_register_csub(CSUB_copy, "copy", 1, 0); 2590 | bone_register_csub(CSUB_say, "say", 0, 1); 2591 | bone_register_csub(CSUB_fastminus, "_fast-", 2, 0); 2592 | bone_register_csub(CSUB_fullminus, "_full-", 1, 1); 2593 | bone_register_csub(CSUB_fast_num_eqp, "_fast=?", 2, 0); 2594 | bone_register_csub(CSUB_fast_num_neqp, "<>?", 2, 0); 2595 | bone_register_csub(CSUB_fast_num_gtp, "_fast>?", 2, 0); 2596 | bone_register_csub(CSUB_fast_num_ltp, "_fast=?", 2, 0); 2598 | bone_register_csub(CSUB_fast_num_leqp, "_fast<=?", 2, 0); 2599 | bone_register_csub(CSUB_each, "each", 2, 0); 2600 | bone_register_csub(CSUB_fastmult, "_fast*", 2, 0); 2601 | bone_register_csub(CSUB_fullmult, "_full*", 0, 1); 2602 | bone_register_csub(CSUB_fastdiv, "_fast/", 2, 0); 2603 | bone_register_csub(CSUB_fulldiv, "_full/", 1, 1); 2604 | bone_register_csub(CSUB_listp, "list?", 1, 0); 2605 | bone_register_csub(CSUB_cat2, "_fast-cat", 2, 0); 2606 | bone_register_csub(CSUB_in_reg, "_in-reg", 1, 0); 2607 | bone_register_csub(CSUB_bind, "_bind", 3, 0); 2608 | bone_register_csub(CSUB_assoc_entry, "assoc-entry?", 2, 0); 2609 | bone_register_csub(CSUB_str_eql, "str=?", 2, 0); 2610 | bone_register_csub(CSUB_str_neql, "str<>?", 2, 0); 2611 | bone_register_csub(CSUB_list_star, "list*", 0, 1); 2612 | bone_register_csub(CSUB_memberp, "member?", 2, 0); 2613 | bone_register_csub(CSUB_reverse, "reverse", 1, 0); 2614 | bone_register_csub(CSUB_mod, "mod", 2, 0); 2615 | bone_register_csub(CSUB_bit_not, "bit-not", 1, 0); 2616 | bone_register_csub(CSUB_bit_and, "bit-and", 2, 0); 2617 | bone_register_csub(CSUB_bit_or, "bit-or", 2, 0); 2618 | bone_register_csub(CSUB_bit_xor, "bit-xor", 2, 0); 2619 | register_cmac(CSUB_quasiquote, "quasiquote", 1, 0); 2620 | bone_register_csub(CSUB_mac_expand_1, "mac-expand-1", 1, 0); 2621 | bone_register_csub(CSUB_mac_bind, "_mac-bind", 3, 0); 2622 | bone_register_csub(CSUB_mac_expand, "mac-expand", 1, 0); 2623 | bone_register_csub(CSUB_boundp, "bound?", 1, 0); 2624 | bone_register_csub(CSUB_mac_bound_p, "mac-bound?", 1, 0); 2625 | bone_register_csub(CSUB_eval, "eval", 1, 0); 2626 | bone_register_csub(CSUB_gensym, "gensym", 0, 0); 2627 | bone_register_csub(CSUB_map, "map", 2, 0); 2628 | bone_register_csub(CSUB_filter, "filter", 2, 0); 2629 | bone_register_csub(CSUB_full_cat, "_full-cat", 0, 1); 2630 | bone_register_csub(CSUB_refers_to, "_refers-to?", 2, 0); 2631 | bone_register_csub(CSUB_load, "_load", 1, 0); 2632 | bone_register_csub(CSUB_var_bind, "_var-bind", 2, 0); 2633 | bone_register_csub(CSUB_with_var, "_with-var", 3, 0); 2634 | bone_register_csub(CSUB_var_bound_p, "var-bound?", 1, 0); 2635 | bone_register_csub(CSUB_var_bang, "_var!", 2, 0); 2636 | bone_register_csub(CSUB_reg_loop, "_reg-loop", 2, 0); 2637 | bone_register_csub(CSUB_err, "err", 0, 1); 2638 | bone_register_csub(CSUB_singlep, "single?", 1, 0); 2639 | bone_register_csub(CSUB_read, "read", 0, 0); 2640 | bone_register_csub(CSUB_chr_read, "chr-read", 0, 0); 2641 | bone_register_csub(CSUB_chr_look, "chr-look", 0, 0); 2642 | register_creader(CSUB_reader_t, "t"); 2643 | register_creader(CSUB_reader_f, "f"); 2644 | bone_register_csub(CSUB_reader_bind, "_reader-bind", 3, 0); 2645 | bone_register_csub(CSUB_reader_bound_p, "reader-bound?", 1, 0); 2646 | bone_register_csub(CSUB_reload, "_reload", 1, 0); 2647 | bone_register_csub(CSUB_sort, "sort", 2, 0); 2648 | bone_register_csub(CSUB_num2str, "num->str", 1, 0); 2649 | bone_register_csub(CSUB_sym2str, "sym->str", 1, 0); 2650 | bone_register_csub(CSUB_src_line, "src-line", 1, 0); 2651 | bone_register_csub(CSUB_file_name, "file-name", 1, 0); 2652 | bone_register_csub(CSUB_with_file_src, "_with-file-src", 2, 0); 2653 | bone_register_csub(CSUB_with_file_dst, "_with-file-dst", 2, 0); 2654 | bone_register_csub(CSUB_eofp, "eof?", 1, 0); 2655 | bone_register_csub(CSUB_srcp, "src?", 1, 0); 2656 | bone_register_csub(CSUB_dstp, "dst?", 1, 0); 2657 | bone_register_csub(CSUB_declare, "_declare", 1, 0); 2658 | bone_register_csub(CSUB_protect, "_protect", 1, 0); 2659 | bone_register_csub(CSUB_dup, "dup", 1, 0); 2660 | bone_register_csub(CSUB_pcons, "_pcons", 2, 0); 2661 | } 2662 | 2663 | //////////////// misc //////////////// 2664 | 2665 | my any copy(any x) { 2666 | switch (tag_of(x)) { 2667 | case t_cons: 2668 | return cons(copy(far(x)), copy(fdr(x))); // FIXME: optimize 2669 | case t_str: 2670 | return str(copy(unstr(x))); 2671 | case t_sym: 2672 | case t_num: 2673 | case t_uniq: 2674 | return x; 2675 | case t_sub: 2676 | return copy_sub(x); 2677 | case t_other: 2678 | switch(get_other_type(x)) { 2679 | case t_other_src: 2680 | return copy_src(x); 2681 | case t_other_dst: 2682 | return copy_dst(x); 2683 | default: 2684 | abort(); 2685 | } 2686 | default: 2687 | abort(); 2688 | } 2689 | } 2690 | 2691 | my void bone_init_thread() { 2692 | call_stack_allocated = 64; 2693 | call_stack = malloc(call_stack_allocated * sizeof(*call_stack)); 2694 | call_stack_pos = 0; 2695 | call_stack->subr = NULL; // FIXME: dummy entry 2696 | call_stack->tail_calls = 0; 2697 | locals_allocated = 256; 2698 | locals_stack = malloc(locals_allocated * sizeof(any)); 2699 | locals_pos = 0; 2700 | upcoming_calls_allocated = 64; 2701 | upcoming_calls = malloc(upcoming_calls_allocated * sizeof(struct upcoming_call)); 2702 | next_call_pos = 0; 2703 | exc_allocated = 8; 2704 | exc_bufs = malloc(exc_allocated * sizeof(struct exc_buf)); 2705 | exc_num = 0; 2706 | reg_allocated = 8; 2707 | reg_stack = malloc(reg_allocated * sizeof(struct reg)); 2708 | permanent_reg = reg_new(); 2709 | reg_stack[0] = permanent_reg; 2710 | load_reg(permanent_reg); 2711 | reg_pos = 0; // refers to TOS 2712 | } 2713 | 2714 | void bone_info_entry(const char *name, int n) { 2715 | set_dyn_val(intern("_*lisp-info*"), cons(list2(intern(name), int2any(n)), get_dyn_val(intern("_*lisp-info*")))); 2716 | } 2717 | 2718 | void bone_init(int argc, char **argv) { 2719 | blocksize = sysconf(_SC_PAGESIZE); 2720 | blockmask = ~(blocksize - 1); 2721 | blockwords = blocksize / sizeof(any); 2722 | free_block = fresh_blocks(); 2723 | bone_init_thread(); 2724 | 2725 | sub_allocp = NULL; 2726 | sub_alloc_left = 0; 2727 | 2728 | sym_ht = hash_new(997, (any)NULL); 2729 | init_syms(); 2730 | 2731 | bindings = hash_new(997, BFALSE); 2732 | macros = hash_new(397, BFALSE); 2733 | readers = hash_new(97, BFALSE); 2734 | init_csubs(); 2735 | dynamics = hash_new(97, BFALSE); 2736 | create_dyn(intern("_*allow-overwrites*"), BFALSE); 2737 | 2738 | any in = fp2src(stdin, charp2str("/dev/stdin")); 2739 | any out = fp2dst(stdout, charp2str("/dev/stdout")); 2740 | create_dyn(intern("*stdin*"), in); 2741 | create_dyn(intern("*stdout*"), out); 2742 | create_dyn(intern("*stderr*"), fp2dst(stderr, charp2str("/dev/stderr"))); 2743 | create_dyn(intern("*src*"), in); 2744 | create_dyn(intern("*dst*"), out); 2745 | dyn_src = any2int(get_dyn(intern("*src*"))); 2746 | dyn_dst = any2int(get_dyn(intern("*dst*"))); 2747 | 2748 | create_dyn(intern("_*lisp-info*"), NIL); 2749 | bone_info_entry("major-version", BONE_MAJOR); 2750 | bone_info_entry("minor-version", BONE_MINOR); 2751 | bone_info_entry("patch-version", BONE_PATCH); 2752 | 2753 | any args = NIL; 2754 | while(argc--) 2755 | args = cons(charp2str(argv[argc]), args); 2756 | create_dyn(intern("*program-args*"), args); 2757 | } 2758 | 2759 | my char *mod2file(const char *mod) { 2760 | size_t len = strlen(mod); 2761 | if(len > 3 && strcmp(".bn", mod + (len - 3)) == 0) 2762 | return strdup(mod); 2763 | char *res = malloc(len + 4); 2764 | strcat(strcpy(res, mod), ".bn"); 2765 | return res; 2766 | } 2767 | 2768 | void bone_load(const char *mod) { 2769 | char *fn = mod2file(mod); 2770 | FILE *src = fopen(fn, "r"); 2771 | if(!src) { 2772 | free(fn); 2773 | generic_error("could not open module", intern(mod)); 2774 | } 2775 | any old = dynamic_vals[dyn_src]; 2776 | dynamic_vals[dyn_src] = fp2src(src, charp2str(fn)); 2777 | free(fn); 2778 | 2779 | bool fail = false; 2780 | in_reg(); 2781 | try { 2782 | if(look() == '#') 2783 | skip_until('\n'); 2784 | any e; 2785 | while((e = bone_read()) != ENDOFFILE) 2786 | eval_toplevel_expr(e); 2787 | } catch { 2788 | eprintf("-> failed to load before "); 2789 | eprint(dynamic_vals[dyn_src]); 2790 | eprintf("\n"); 2791 | fail = true; 2792 | } 2793 | last_value = to_bool(!fail); 2794 | end_in_reg(); 2795 | fclose(src); 2796 | dynamic_vals[dyn_src] = old; 2797 | if(fail) 2798 | throw(); 2799 | } 2800 | 2801 | void bone_repl() { 2802 | create_dyn(intern("$"), BFALSE); // FIXME: repl can now only be called once 2803 | create_dyn(intern("$$"), BFALSE); 2804 | 2805 | int line = 0; 2806 | while(1) { 2807 | printf("\n@%d: ", line++); 2808 | try { 2809 | any e = bone_read(); 2810 | if(e == ENDOFFILE) 2811 | break; 2812 | eval_toplevel_expr(e); 2813 | print(last_value); 2814 | set_dyn_val(intern("$$"), get_dyn_val(intern("$"))); 2815 | set_dyn_val(intern("$"), last_value); 2816 | } catch { 2817 | call_stack_pos = 0; 2818 | } 2819 | } 2820 | printf("\n"); 2821 | } 2822 | -------------------------------------------------------------------------------- /bone.h: -------------------------------------------------------------------------------- 1 | /* bone.h -- The Bone Lisp header file. 2 | * Copyright (C) 2016 Wolfgang Jaehrling 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #ifndef BONE_H 18 | #define BONE_H 19 | 20 | #define BONE_MAJOR 0 21 | #define BONE_MINOR 6 22 | #define BONE_PATCH 0 23 | #define BONE_VERSION_EXTRA "-pre" 24 | 25 | #include 26 | #include 27 | #include 28 | 29 | #define STRINGIFY1(x) #x 30 | #define STRINGIFY(x) STRINGIFY1(x) 31 | #define BONE_VERSION STRINGIFY(BONE_MAJOR) "." STRINGIFY(BONE_MINOR) "." STRINGIFY(BONE_PATCH) BONE_VERSION_EXTRA 32 | 33 | #define my static 34 | typedef uint64_t any; // we only support 64 bit currently 35 | typedef void (*csub)(any *); 36 | typedef enum { t_cons = 0, t_sym = 1, t_uniq = 2, t_str = 3, /*t_unused = 4,*/ t_sub = 5, t_num = 6, t_other = 7 } type_tag; 37 | typedef enum { t_other_src, t_other_dst } type_other_tag; 38 | typedef enum { t_num_int, t_num_float } type_num_tag; 39 | #define BONE_INT_MIN -576460752303423488 /* -(2^59) */ 40 | #define BONE_INT_MAX 576460752303423487 /* 2^59 - 1 */ 41 | #define UNIQ(n) (t_uniq | (010*(n))) 42 | #define NIL UNIQ(0) 43 | #define BTRUE UNIQ(1) 44 | #define BFALSE UNIQ(2) 45 | #define ENDOFFILE UNIQ(3) 46 | 47 | void bone_init(int argc, char **argv); 48 | void bone_load(const char *file); 49 | void bone_repl(); 50 | void bone_result(any x); 51 | void bone_register_csub(csub cptr, const char *name, int argc, int take_rest); 52 | 53 | #define DEFSUB(name) my void CSUB_ ## name(any *args) 54 | 55 | bool is_nil(any x); 56 | bool is(any x); 57 | any to_bool(bool x); 58 | 59 | type_other_tag get_other_type(any x); 60 | void check(any x, type_tag t); 61 | 62 | int64_t any2int(any x); 63 | any int2any(int64_t n); 64 | 65 | any cons(any a, any d); 66 | my any precons(any a); 67 | any far(any x); 68 | any fdr(any x); 69 | any car(any x); 70 | any cdr(any x); 71 | void set_far(any cell, any x); 72 | void set_fdr(any cell, any x); 73 | bool is_cons(any x); 74 | bool is_single(any x); 75 | any single(any x); 76 | int64_t len(any x); 77 | any list2(any a, any b); 78 | any list3(any a, any b, any c); 79 | #define foreach(var, lst) for(any p_ = (lst), var; is_cons(p_) && (var = far(p_), 1); p_ = fdr(p_)) 80 | #define foreach_cons(var, lst) for(any var = (lst); is_cons(var); var = fdr(var)) 81 | 82 | typedef struct { any xs, last; } listgen; 83 | listgen listgen_new(); 84 | void listgen_add(listgen *lg, any x); 85 | 86 | void call0(any subr); 87 | void call1(any subr, any x); 88 | void call2(any subr, any x, any y); 89 | 90 | bool is_str(any x); 91 | any charp2str(const char *p); 92 | char *str2charp(any x); // created w/ malloc() 93 | 94 | any intern(const char *name); 95 | char *symtext(any sym); 96 | 97 | any fp2src(FILE *fp, any name); 98 | any fp2dst(FILE *fp, any name); 99 | FILE *src2fp(any x); 100 | FILE *dst2fp(any x); 101 | 102 | jmp_buf *begin_try_(); 103 | jmp_buf *throw_(); 104 | void end_try_(); 105 | 106 | #define try if(!setjmp(*begin_try_())) { 107 | #define throw() longjmp(*throw_(), 1) 108 | #define catch end_try_(); } else 109 | 110 | void bone_info_entry(const char *name, int n); 111 | 112 | #endif /* BONE_H */ 113 | -------------------------------------------------------------------------------- /boneposix.c: -------------------------------------------------------------------------------- 1 | /* boneposix.c -- POSIX bindings for Bone Lisp. 2 | * Copyright (C) 2016 Wolfgang Jaehrling 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | 31 | #include "bone.h" 32 | 33 | my int my_errno; // b/c we might alloc mem to store result after syscall 34 | my void ses() { my_errno = errno; } // Safe Error Status 35 | DEFSUB(errno) { bone_result(int2any(my_errno)); } 36 | DEFSUB(errname) { 37 | switch (my_errno) { 38 | #define x(n) case n: bone_result(intern(#n)); break 39 | // C99 + POSIX 40 | x(E2BIG); x(EACCES); x(EADDRINUSE); x(EADDRNOTAVAIL); 41 | x(EAFNOSUPPORT); x(EAGAIN); x(EALREADY); x(EBADF); 42 | x(EBADMSG); x(EBUSY); x(ECANCELED); x(ECHILD); 43 | x(ECONNABORTED); x(ECONNREFUSED); x(ECONNRESET); x(EDEADLK); 44 | x(EDESTADDRREQ); x(EDOM); x(EDQUOT); x(EEXIST); 45 | x(EFAULT); x(EFBIG); x(EHOSTUNREACH); x(EIDRM); 46 | x(EILSEQ); x(EINPROGRESS); x(EINTR); x(EINVAL); 47 | x(EIO); x(EISCONN); x(EISDIR); x(ELOOP); 48 | x(EMFILE); x(EMLINK); x(EMSGSIZE); x(EMULTIHOP); 49 | x(ENAMETOOLONG); x(ENETDOWN); x(ENETRESET); x(ENETUNREACH); 50 | x(ENFILE); x(ENOBUFS); x(ENODATA); x(ENODEV); 51 | x(ENOENT); x(ENOEXEC); x(ENOLCK); x(ENOLINK); 52 | x(ENOMEM); x(ENOMSG); x(ENOPROTOOPT); x(ENOSPC); 53 | x(ENOSR); x(ENOSTR); x(ENOSYS); x(ENOTCONN); 54 | x(ENOTDIR); x(ENOTEMPTY); x(ENOTSOCK); x(ENOTSUP); 55 | x(ENOTTY); x(ENXIO); x(EOVERFLOW); x(EPERM); 56 | x(EPIPE); x(EPROTO); x(EPROTONOSUPPORT); x(EPROTOTYPE); 57 | x(ERANGE); x(EROFS); x(ESPIPE); x(ESRCH); 58 | x(ESTALE); x(ETIME); x(ETIMEDOUT); x(ETXTBSY); 59 | x(EXDEV); 60 | #ifndef __linux__ // the following are duplicates on GNU/Linux: 61 | x(EOPNOTSUPP); // same as ENOTSUPP 62 | x(EWOULDBLOCK); // same as EDOM 63 | #else // GNU/Linux specific: 64 | x(EBADE); x(EBADFD); x(EBADR); x(EBADRQC); 65 | x(EBADSLT); x(ECHRNG); x(ECOMM); x(EHOSTDOWN); 66 | x(EISNAM); x(EKEYEXPIRED); x(EKEYREJECTED); x(EKEYREVOKED); 67 | x(EL2HLT); x(EL2NSYNC); x(EL3HLT); x(EL3RST); 68 | x(ELIBACC); x(ELIBBAD); x(ELIBEXEC); x(ELIBMAX); 69 | x(ELIBSCN); x(EMEDIUMTYPE); x(ENOKEY); x(ENOMEDIUM); 70 | x(ENONET); x(ENOPKG); x(ENOTBLK); x(ENOTUNIQ); 71 | x(EPFNOSUPPORT); x(EREMCHG); x(EREMOTE); x(EREMOTEIO); 72 | x(ERESTART); x(ESHUTDOWN); x(ESOCKTNOSUPPORT); x(ESTRPIPE); 73 | x(EUCLEAN); x(EUNATCH); x(EUSERS); x(EXFULL); 74 | // x(EDEADLOCK); // same as EDEADLK 75 | #endif 76 | #undef x 77 | default: 78 | bone_result(BFALSE); 79 | } 80 | } 81 | 82 | DEFSUB(getpid) { bone_result(int2any(getpid())); } 83 | DEFSUB(getuid) { bone_result(int2any(getuid())); } 84 | DEFSUB(geteuid) { bone_result(int2any(geteuid())); } 85 | DEFSUB(getgid) { bone_result(int2any(getgid())); } 86 | DEFSUB(getegid) { bone_result(int2any(getegid())); } 87 | 88 | my void getenv_any(char *name) { 89 | char *res = getenv(name); 90 | ses(); 91 | bone_result(res ? charp2str(res) : BFALSE); 92 | } 93 | 94 | my void getenv_str(any x) { 95 | char *name = str2charp(x); 96 | getenv_any(name); 97 | free(name); 98 | } 99 | 100 | my void getenv_sym(any x) { getenv_any(symtext(x)); } 101 | DEFSUB(getenv) { 102 | if (is_str(args[0])) 103 | getenv_str(args[0]); 104 | else 105 | getenv_sym(args[0]); 106 | } 107 | 108 | my void setenv_any(char *name, char *val, any ow) { 109 | bone_result(to_bool(!setenv(name, val, is(ow)))); 110 | ses(); 111 | } 112 | 113 | my void setenv_str(any x, char *val, any ow) { 114 | char *name = str2charp(x); 115 | setenv_any(name, val, ow); 116 | free(name); 117 | } 118 | 119 | my void setenv_sym(any x, char *val, any ow) { 120 | setenv_any(symtext(x), val, ow); 121 | } 122 | 123 | DEFSUB(setenv) { 124 | char *val = str2charp(args[1]); 125 | if (is_str(args[0])) 126 | setenv_str(args[0], val, args[2]); 127 | else 128 | setenv_sym(args[0], val, args[2]); 129 | free(val); 130 | } 131 | 132 | DEFSUB(chdir) { 133 | char *d = str2charp(args[0]); 134 | bone_result(to_bool(!chdir(d))); 135 | ses(); 136 | free(d); 137 | } 138 | 139 | // FIXME: 1024 140 | DEFSUB(getcwd) { 141 | char d[1024], *r = getcwd(d, 1024); 142 | ses(); 143 | bone_result((r == d) ? charp2str(d) : BFALSE); 144 | } 145 | 146 | DEFSUB(time) { 147 | time_t t = time(NULL); 148 | ses(); 149 | bone_result((t != -1) ? int2any(t) : BFALSE); 150 | } 151 | 152 | DEFSUB(ctime) { 153 | char buf[32]; // ctime_r(3) says it should be "at least 26" 154 | time_t t = any2int(args[0]); 155 | char *ok = ctime_r(&t, buf); 156 | ses(); 157 | bone_result(ok ? charp2str(buf) : BFALSE); 158 | } 159 | 160 | DEFSUB(gettimeofday) { 161 | struct timeval tv; 162 | int res = gettimeofday(&tv, NULL); 163 | ses(); 164 | bone_result((res != -1) ? list2(int2any(tv.tv_sec), int2any(tv.tv_usec)) : BFALSE); 165 | } 166 | 167 | DEFSUB(mkdir) { 168 | char *d = str2charp(args[0]); 169 | int res = mkdir(d, any2int(args[1])); 170 | ses(); 171 | free(d); 172 | bone_result(to_bool(!res)); 173 | } 174 | 175 | DEFSUB(rmdir) { 176 | char *d = str2charp(args[0]); 177 | int res = rmdir(d); 178 | ses(); 179 | free(d); 180 | bone_result(to_bool(!res)); 181 | } 182 | 183 | DEFSUB(link) { 184 | char *old = str2charp(args[0]); 185 | char *new = str2charp(args[1]); 186 | int res = link(old, new); 187 | ses(); 188 | free(new); 189 | free(old); 190 | bone_result(to_bool(!res)); 191 | } 192 | 193 | DEFSUB(symlink) { 194 | char *old = str2charp(args[0]); 195 | char *new = str2charp(args[1]); 196 | int res = symlink(old, new); 197 | ses(); 198 | free(new); 199 | free(old); 200 | bone_result(to_bool(!res)); 201 | } 202 | 203 | DEFSUB(rename) { 204 | char *old = str2charp(args[0]); 205 | char *new = str2charp(args[1]); 206 | int res = rename(old, new); 207 | ses(); 208 | free(new); 209 | free(old); 210 | bone_result(to_bool(!res)); 211 | } 212 | 213 | DEFSUB(unlink) { 214 | char *f = str2charp(args[0]); 215 | int res = unlink(f); 216 | ses(); 217 | free(f); 218 | bone_result(to_bool(!res)); 219 | } 220 | 221 | DEFSUB(chmod) { 222 | char *f = str2charp(args[0]); 223 | int res = chmod(f, any2int(args[1])); 224 | ses(); 225 | free(f); 226 | bone_result(to_bool(!res)); 227 | } 228 | 229 | DEFSUB(umask) { bone_result(int2any(umask(any2int(args[0])))); } 230 | 231 | DEFSUB(dir_entries) { 232 | char *d = str2charp(args[0]); 233 | struct dirent **ents; 234 | 235 | int n = scandir(d, &ents, NULL, alphasort); 236 | ses(); 237 | free(d); 238 | if (n == -1) { 239 | bone_result(BFALSE); 240 | return; 241 | } 242 | 243 | listgen lg = listgen_new(); 244 | for (int i = 0; i < n; i++) { 245 | listgen_add(&lg, charp2str(ents[i]->d_name)); 246 | free(ents[i]); 247 | } 248 | free(ents); 249 | bone_result(lg.xs); 250 | } 251 | 252 | DEFSUB(kill) { 253 | int res = kill(any2int(args[0]), any2int(args[1])); 254 | ses(); 255 | bone_result(to_bool(!res)); 256 | } 257 | 258 | DEFSUB(exit) { exit(any2int(args[0])); } 259 | 260 | DEFSUB(fork) { 261 | int res = fork(); 262 | ses(); 263 | bone_result((res != -1) ? int2any(res) : BFALSE); 264 | } 265 | 266 | DEFSUB(waitpid) { // FIXME: flags as syms 267 | int status, res = waitpid(any2int(args[0]), &status, any2int(args[1])); 268 | ses(); 269 | bone_result((res != -1) ? list2(int2any(res), int2any(status)) : BFALSE); 270 | } 271 | 272 | // With these you can analyze the status returned by waitpid: 273 | DEFSUB(w_exitstatus) { 274 | int x = any2int(args[0]); 275 | bone_result(WIFEXITED(x) ? int2any(WEXITSTATUS(x)) : BFALSE); 276 | } 277 | DEFSUB(w_termsig) { 278 | int x = any2int(args[0]); 279 | bone_result(WIFSIGNALED(x) ? int2any(WTERMSIG(x)) : BFALSE); 280 | } 281 | DEFSUB(w_stopsig) { 282 | int x = any2int(args[0]); 283 | bone_result(WIFSTOPPED(x) ? int2any(WSTOPSIG(x)) : BFALSE); 284 | } 285 | DEFSUB(w_continued) { bone_result(to_bool(WIFCONTINUED(any2int(args[0])))); } 286 | 287 | DEFSUB(random) { bone_result(int2any(random() % any2int(args[0]))); } 288 | 289 | DEFSUB(src_open) { 290 | char *fname = str2charp(args[0]); 291 | FILE *fp = fopen(fname, "r"); 292 | ses(); 293 | free(fname); 294 | bone_result(fp ? fp2src(fp, args[0]) : BFALSE); 295 | } 296 | 297 | DEFSUB(src_close) { 298 | bool res = (fclose(src2fp(args[0])) == 0); 299 | ses(); 300 | bone_result(to_bool(res)); 301 | } 302 | 303 | DEFSUB(dst_open) { 304 | char *fname = str2charp(args[0]); 305 | FILE *fp = fopen(fname, "w"); 306 | ses(); 307 | free(fname); 308 | bone_result(fp ? fp2dst(fp, args[0]) : BFALSE); 309 | } 310 | 311 | DEFSUB(dst_close) { 312 | bool res = (fclose(dst2fp(args[0])) == 0); 313 | ses(); 314 | bone_result(to_bool(res)); 315 | } 316 | 317 | DEFSUB(execvp) { 318 | char *prog = str2charp(args[0]); 319 | check(args[1], t_cons); // avoid invalid syscall 320 | int64_t argc = len(args[1]); 321 | char **argv = malloc((argc+1) * sizeof(char *)); 322 | int64_t i = 0; 323 | foreach(arg, args[1]) 324 | argv[i++] = str2charp(arg); 325 | argv[i] = NULL; 326 | execvp(prog, argv); 327 | ses(); 328 | free(prog); 329 | while(i--) 330 | free(argv[i]); 331 | free(argv); 332 | bone_result(BFALSE); 333 | } 334 | 335 | DEFSUB(strerror) { 336 | locale_t loc = newlocale(LC_MESSAGES_MASK, "", NULL); 337 | char *msg = strerror_l(any2int(args[0]), loc); 338 | freelocale(loc); 339 | any res = charp2str(msg); 340 | bone_result(res); 341 | } 342 | 343 | void bone_posix_init() { 344 | bone_register_csub(CSUB_errno, "sys.errno", 0, 0); 345 | bone_register_csub(CSUB_errname, "sys.errname?", 0, 0); 346 | bone_register_csub(CSUB_getpid, "sys.getpid", 0, 0); 347 | bone_register_csub(CSUB_getuid, "sys.getuid", 0, 0); 348 | bone_register_csub(CSUB_geteuid, "sys.geteuid", 0, 0); 349 | bone_register_csub(CSUB_getgid, "sys.getgid", 0, 0); 350 | bone_register_csub(CSUB_getegid, "sys.getegid", 0, 0); 351 | bone_register_csub(CSUB_getenv, "sys.getenv?", 1, 0); 352 | bone_register_csub(CSUB_setenv, "sys.setenv?", 3, 0); // FIXME: last arg optional 353 | bone_register_csub(CSUB_chdir, "sys.chdir?", 1, 0); 354 | bone_register_csub(CSUB_getcwd, "sys.getcwd?", 0, 0); 355 | bone_register_csub(CSUB_time, "sys.time?", 0, 0); 356 | bone_register_csub(CSUB_gettimeofday, "sys.gettimeofday?", 0, 0); 357 | bone_register_csub(CSUB_mkdir, "sys.mkdir?", 2, 0); 358 | bone_register_csub(CSUB_rmdir, "sys.rmdir?", 1, 0); 359 | bone_register_csub(CSUB_link, "sys.link?", 2, 0); 360 | bone_register_csub(CSUB_symlink, "sys.symlink?", 2, 0); 361 | bone_register_csub(CSUB_rename, "sys.rename?", 2, 0); 362 | bone_register_csub(CSUB_unlink, "sys.unlink?", 1, 0); 363 | bone_register_csub(CSUB_chmod, "sys.chmod?", 2, 0); 364 | bone_register_csub(CSUB_umask, "sys.umask", 1, 0); 365 | bone_register_csub(CSUB_dir_entries, "sys.dir-entries?", 1, 0); 366 | bone_register_csub(CSUB_kill, "sys.kill?", 2, 0); 367 | bone_register_csub(CSUB_exit, "sys.exit", 1, 0); 368 | bone_register_csub(CSUB_fork, "sys.fork?", 0, 0); 369 | bone_register_csub(CSUB_waitpid, "sys.waitpid?", 2, 0); 370 | bone_register_csub(CSUB_w_exitstatus, "sys.exitstatus?", 1, 0); 371 | bone_register_csub(CSUB_w_termsig, "sys.termsig?", 1, 0); 372 | bone_register_csub(CSUB_w_stopsig, "sys.stopsig?", 1, 0); 373 | bone_register_csub(CSUB_w_continued, "sys.continued?", 1, 0); 374 | bone_register_csub(CSUB_random, "sys.random", 1, 0); 375 | bone_register_csub(CSUB_src_open, "sys.src-open?", 1, 0); 376 | bone_register_csub(CSUB_src_close, "sys.src-close?", 1, 0); 377 | bone_register_csub(CSUB_dst_open, "sys.dst-open?", 1, 0); 378 | bone_register_csub(CSUB_dst_close, "sys.dst-close?", 1, 0); 379 | bone_register_csub(CSUB_ctime, "sys.ctime?", 1, 0); 380 | bone_register_csub(CSUB_execvp, "sys.execvp?", 2, 0); 381 | bone_register_csub(CSUB_strerror, "sys.strerror", 1, 0); 382 | 383 | srandom(time(NULL)); 384 | bone_info_entry("posix", 0); 385 | } 386 | -------------------------------------------------------------------------------- /boneposix.h: -------------------------------------------------------------------------------- 1 | /* boneposix.h -- POSIX bindings for Bone Lisp. 2 | * Copyright (C) 2016 Wolfgang Jaehrling 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #ifndef BONE_POSIX_H 18 | #define BONE_POSIX_H 19 | 20 | void bone_posix_init(); 21 | 22 | #endif /* BONE_POSIX_H */ 23 | -------------------------------------------------------------------------------- /core.bn: -------------------------------------------------------------------------------- 1 | ;;;; core.bn -- Documentation for Bone Lisp core operations. -*- lisp -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | ;;;; Note: This file just provides the docstrings for the operations 17 | ;;;; in the core. You will not find any implementation here. This 18 | ;;;; file should not be evaluated, it should only be parsed by a 19 | ;;;; documentation generator. This file uses `defspecial` to document 20 | ;;;; special forms. 21 | 22 | (defspecial (if test then . else) 23 | "If `test` yields true, evaluate `then`, otherwise all expressions in `else`. 24 | 25 | If `else` is empty and `test` is false, returns false. 26 | 27 | The only value that does not count as true is `#f`, the booolean false 28 | value. This means that the empty list as well as the number zero are 29 | considered to be true values. See `nil?` and `zero?` if you want to 30 | check for those values.") 31 | 32 | (defspecial (quote . obj) 33 | "Returns `obj`, unevaluated.") 34 | 35 | (defspecial (do . exprs) 36 | "Evaluate the `exprs` in order.") 37 | 38 | (defspecial (with name value . exprs) 39 | "Bind `name` to `value`, then evaluate the `exprs` in order.") 40 | 41 | (defspecial (lambda args . body) 42 | "Create an anonymous sub with arguments `args` and code `body` (which may not be empty). 43 | 44 | `args` can be either a `sym` or a list of `sym`s; if it is a list, it 45 | may be improper, but only if it has a `sym` as rest. This means: 46 | 47 | * `(lambda x ...)` will bind the list of arguments to `x`. 48 | * `(lambda (a b) ...)` will find two arguments to `a` and `b`, respectively. 49 | * `(lambda (a b . x) ...)` will bind two arguments to `a` and `b`, 50 | as well as all remaining arguments to `x`. 51 | 52 | `body` is a list of expressions, which will be evaluated in order. 53 | 54 | The anonymous sub that is created will be lexically scoped, 55 | i.e. bindings defined in an outer scope may be used and are 56 | encapsulated if the sub is passed back as a return value.") 57 | 58 | (defmac (quasiquote . form) 59 | "Quote `form`, except for unquoted parts. 60 | 61 | This macro is generally used via its short form `\\`form`. It works 62 | like `quote`, but may contain `(unquote x)` forms which will cause x` 63 | to appear unquoted in the result. For `unquote` the abbreviation 64 | `,` (comma) is available. `(unquote-splicing x)` or `,@x` forms 65 | expect `x` to evaluate to a list, which will be embedded into the 66 | resulting list, i.e.: 67 | 68 | `(a b c ,@(list 1 2 3) d e f) 69 | ; => (a b c 1 2 3 d e f)") 70 | 71 | (defsub (mac-expand-1 form) 72 | "Expand macros in `form` once, i.e. show the immediate result of macro expansion.") 73 | 74 | (defsub (mac-expand form) 75 | "Expand macros in `form` repeatedly until there are no macros anymore.") 76 | 77 | (defsub (bound? sym) 78 | "Check whether `sym` is bound.") 79 | 80 | (defsub (mac-bound? sym) 81 | "Check whether `sym` is bound in the macro namespace.") 82 | 83 | (defsub (var-bound? sym) 84 | "Check whether `sym` is bound in the dynamic variable namespace.") 85 | 86 | (defsub (reader-bound? sym) 87 | "Check whether `sym` is bound in the reader macro namespace.") 88 | 89 | (defsub (eval x) 90 | "Evaluate `x`; this allows to generate code at runtime.") 91 | 92 | (defsub (id x) 93 | "This is the identity sub; it simply returns `x`. 94 | 95 | This is sometimes useful in higher order programming.") 96 | 97 | (defsub (eq? a b) 98 | "Returns whether `a` and `b` are the same object. 99 | 100 | Don't use this for comparing numbers, use `=?` instead. The most 101 | important use of `eq?` is as a quick way to compare `sym`s.") 102 | 103 | (defsub (copy x) 104 | "Return a newly allocated copy of `x`.") 105 | 106 | (defsub (not x) 107 | "Boolean negation: Return whether `x` is false. 108 | 109 | Do not confuse this with `no` or `nil?`, which test for the empty list.") 110 | 111 | (defsub (sub? x) 112 | "Return whether `x` is a sub.") 113 | 114 | (defsub (apply sub . args) 115 | "Apply `sub` to the given arguments, the last value in `args` must be a list. 116 | 117 | The exact behaviour is best explained with examples: 118 | * `(apply f)` is `(f)` 119 | * `(apply f '(1 2 3))` is `(f 1 2 3)` 120 | * `(apply f 1 2 '(3 4))` is `(f 1 2 3 4)` 121 | 122 | This allows to use a list as the arguments to a sub, while also having 123 | fixed arguments at the same time (without a need for consing them to 124 | the front of the list manually). See also `list*`.") 125 | 126 | (defsub (cons a d) 127 | "Create a cons cell containing `a` as car and `d` as cdr.") 128 | 129 | (defsub (car x) 130 | "Return the car (first element) of the cons cell `x`. 131 | 132 | Note that `car` and `cdr` are low-level operations which usually 133 | should not appear in application code. Instead, higher-level list 134 | operations should be used (which may be implemented in terms of `car` 135 | and `cdr`).") 136 | 137 | (defsub (cdr x) 138 | "Return the cdr (second element) of the cons cell `x`. 139 | 140 | See `car` for additional usage information.") 141 | 142 | (defsub (cons? x) 143 | "Return whether `x` is a `cons` cell.") 144 | 145 | (defsub (nil? x) 146 | "Return whether `x` is the empty list.") 147 | 148 | (defsub (single? x) 149 | "Check whether `x` is a list of exactly one element. 150 | 151 | `x` may be any object, it does not have to be a list.") 152 | 153 | (defsub (list? x) 154 | "Return whether `x` is a list (i.e. either a `cons` or nil).") 155 | 156 | (defsub (list . xs) 157 | "Returns `xs`. 158 | 159 | This is a basic list constructor; it's more convenient (and faster) 160 | than nested `cons` calls.") 161 | 162 | (defsub (list* . xs) 163 | "Create a list consisting of the elements of `xs`, but using the last element as rest. 164 | 165 | This means that `(list* 1 2 3)` returns `(1 2 . 3)`.") 166 | 167 | (defsub (len xs) 168 | "Return the number of elements in `xs`.") 169 | 170 | (defsub (dup xs) 171 | "Duplicate the list `xs`; the elements will not be duplicated.") 172 | 173 | (defsub (cat . lists) 174 | "Concatenate the `lists` into a single list.") 175 | 176 | (defsub (reverse xs) 177 | "Return a list with the elements of `xs`, but in opposite order.") 178 | 179 | (defsub (member? x xs) 180 | "Return whether `x` is in the list `xs`.") 181 | 182 | (defsub (each sub xs) 183 | "Apply `sub` to every element of the list `xs` in sequence. 184 | 185 | The result should be ignored, but will be the result of the last call to `sub`.") 186 | 187 | (defsub (map sub xs) 188 | "Call `sub` for each element in `xs` and return a list of the results.") 189 | 190 | (defsub (filter keep? xs) 191 | "Call `keep?` for each element in `xs` and return a list of the elements where the result was true.") 192 | 193 | (defsub (sort is>? xs) 194 | "Sort `xs` according to the predicate `is>?`.") 195 | 196 | (defsub (assoc? x alist) 197 | "Get the value corresponding to the key `x` in `alist` (`#f` if not found). 198 | 199 | This sub will return the `cdr` where the `car` is `x`.") 200 | 201 | (defsub (assoc-entry? x alist) 202 | "Returns the key/value entry from `alist` with the key `x` (`#f` if not found).") 203 | 204 | (defsub (num? x) 205 | "Return whether `x` is a number.") 206 | 207 | (defsub (integer? x) 208 | "Return whether `x` is an integer number.") 209 | 210 | (defsub (float? x) 211 | "Return whether `x` is a floating-point number.") 212 | 213 | (defsub (round x) 214 | "Round `x` to the nearest integer number.") 215 | 216 | (defsub (floor x) 217 | "Round `x` to the nearest integer number smaller than `x`.") 218 | 219 | (defsub (ceil x) 220 | "Round `x` to the nearest integer number greater than `x`.") 221 | 222 | (defsub (trunc x) 223 | "Round `x` towards zero to the nearest integer number.") 224 | 225 | (defsub (+ . nums) 226 | "Return the sum of the numbers in `nums` (which may not contain anything but numbers).") 227 | 228 | (defsub (- n . nums) 229 | "Arithmetic minus: The sum of `nums` will be subtracted from `n`. 230 | 231 | This is not the traditional behaviour of `-` in Lisp, which did allow 232 | the unary minus `(- x)` as an alias for `(- 0 x)`. This was removed 233 | from Bone Lisp because it would cause trouble with constructs 234 | like `(apply - num xs)` giving unexpected results when `xs` is 235 | empty.") 236 | 237 | (defsub (* . nums) 238 | "Return the product of the numbers in `nums` (which may not contain anything but numbers). 239 | 240 | When applied to the empty list (as in `(*)` or `(apply * ())`), the result is 1.") 241 | 242 | (defsub (/ dividend . divisors) 243 | "Divide the `dividend` by the product of all `divisors`.") 244 | 245 | (defsub (mod dividend divisor) 246 | "Return the remainder of dividing `dividend` by `divisor`.") 247 | 248 | (defsub (=? . nums) 249 | "Return whether the numbers in `nums` are all equal.") 250 | 251 | (defsub (<>? a b) 252 | "Return whether the numbers `a` and `b` are different. 253 | 254 | Note that this sub accepts only two arguments, while similar subs like 255 | `=?` accept an arbitrary number of args.") 256 | 257 | (defsub (>? . nums) 258 | "Return whether each number in `nums` is greater than the next.") 259 | 260 | (defsub (=? . nums) 264 | "Return whether each number in `nums` is greater than or equal to the next.") 265 | 266 | (defsub (<=? . nums) 267 | "Return whether each number in `nums` is less than or equal to the next.") 268 | 269 | (defsub (bit-not n) 270 | "Return the bitwise negation of `n` (i.e. flip each bit).") 271 | 272 | (defsub (bit-and n1 n2) 273 | "Return the bitwise AND of `n1` and `n2`.") 274 | 275 | (defsub (bit-or n1 n2) 276 | "Return the bitwise OR (inclusive or) of `n1` and `n2`.") 277 | 278 | (defsub (bit-xor n1 n2) 279 | "Return the bitwise XOR (exclusive or) of `n1` and `n2`.") 280 | 281 | (defsub (str? x) 282 | "Return whether `x` is a string (a `str`).") 283 | 284 | (defsub (str chrs) 285 | "Return a new `str` with the characters from the list `chrs`.") 286 | 287 | (defsub (unstr s) 288 | "Return the list of characters in `s`.") 289 | 290 | (defsub (str=? s1 s2) 291 | "Return whether `str1` and `str2` consist of the same characters.") 292 | 293 | (defsub (str<>? s1 s2) 294 | "Return whether `str1` and `str2` consist of different characters.") 295 | 296 | (defsub (num->str n) 297 | "Return a representation of `n` as a str.") 298 | 299 | (defsub (print x) 300 | "Print `x` as an extended symbolic expression. 301 | 302 | This will print the object so that it can be read by humans and also 303 | read back by the Lisp reader, except if it contains objects which 304 | cannot be read back, like `sub`s. Reading back is possible as long as 305 | it only contains lists, `sym`s, numbers and bools. The abbreviations 306 | for `quote`, `quasiquote`, `unquote`, `unquote-splicing` and `lambda` 307 | will be printed to keep the output short and as human-readable as 308 | possible.") 309 | 310 | (defsub (say . xs) 311 | "Print all `xs`. 312 | 313 | The differences to the `print` sub are: 314 | * A `str` is printed without the quote signs and without escape sequences. 315 | * A list is printed by applying it to `say`. 316 | * All other objects are printed as with `print`. 317 | 318 | Always returns `#t`.") 319 | 320 | (defsub (err . xs) 321 | "Print all of `xs` as with `say`, then raise an error.") 322 | 323 | (defsub (read) 324 | "Read a symbolic expression from the current src.") 325 | 326 | (defsub (chr-read) 327 | "Read a single character from the current src.") 328 | 329 | (defsub (chr-look) 330 | "Look ahead at the next character from the current src without reading it.") 331 | 332 | (defsub (src-line src) 333 | "The current line number of `src`.") 334 | 335 | (defsub (file-name src-or-dst) 336 | "The file name associated with `src-or-dst`.") 337 | 338 | (defsub (src? x) 339 | "Check whether `x` is a src.") 340 | 341 | (defsub (dst? x) 342 | "Check whether `x` is a dst.") 343 | 344 | (defsub (eof? x) 345 | "Check whether `x` is the end of file object.") 346 | 347 | (defsub (sym? x) 348 | "Return whether `x` is a sym.") 349 | 350 | (defsub (intern s) 351 | "Return the `sym` with the text of `str`. 352 | 353 | If it does not exist yet, it will be created.") 354 | 355 | (defsub (sym->str symbol) 356 | "Return the name of the sym `symbol` as a str.") 357 | 358 | (defsub (gensym) 359 | "Return a new non-interned sym. 360 | 361 | This is especially useful to avoid naming conflicts in macros.") 362 | -------------------------------------------------------------------------------- /gendoc.bn: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bone 2 | ;;;; gendoc.bn -- Documentation generator for Bone Lisp. -*- bone -*- 3 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 4 | ;;;; 5 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 6 | ;;;; purpose with or without fee is hereby granted, provided that the above 7 | ;;;; copyright notice and this permission notice appear in all copies. 8 | ;;;; 9 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | 17 | (version 0 6) 18 | 19 | ;;; Program options 20 | 21 | (use std/prog-arg) 22 | 23 | (defvar *options-spec* 24 | '((index ((flag #t) 25 | (short #chr "i") 26 | (desc "Generate index.md file."))) 27 | (help ((flag #t) 28 | (short #chr "h") 29 | (desc "Show this usage message."))) 30 | (version ((flag #t) 31 | (short #chr "v") 32 | (desc "Show version information."))))) 33 | 34 | 35 | (destructure (options files) 36 | (parse-prog-args (drop 2 *program-args*) *options-spec*) 37 | (defvar *options* options) 38 | (defvar *files* files)) 39 | 40 | (mysub (bone-version) 41 | (str+ (num->str (lisp-info 'major-version)) "." 42 | (num->str (lisp-info 'minor-version)) "." 43 | (num->str (lisp-info 'patch-version)))) 44 | 45 | (cond ((assocar? 'help *options*) 46 | (say-prog-args-help "gendoc" *options-spec* "FILE...") 47 | (sys.exit 0)) 48 | ((assocar? 'version *options*) 49 | (say "gendoc " (bone-version) "\n") 50 | (sys.exit 0))) 51 | 52 | ;;; Main program 53 | 54 | (defvar *index-dst* (when (assocar? 'index *options*) 55 | (sys.dst-open? "index.md"))) ; TODO: abort on error 56 | (defvar *current-file* #f) 57 | 58 | (mymac (to-index-dst . body) 59 | `(when *index-dst* 60 | (with-dst *index-dst* 61 | ,@body))) 62 | 63 | (mysub (spec->name spec) 64 | (or (car? spec) spec)) 65 | 66 | (mysub (index-entry name) 67 | (to-index-dst 68 | (say "[`" name "`](" *current-file* "#" name ") "))) 69 | 70 | (mysub (document type spec docstr) 71 | (index-entry (spec->name spec)) 72 | (say "### name spec) "\"> " type ": `") 73 | (print spec) 74 | (say "` \n\n" docstr "\n\n")) 75 | 76 | (mysub (look-at-expr x) 77 | (with head (car? x) 78 | (awhen (cond ((eq? head 'defsub) 'sub) 79 | ((eq? head 'defmac) 'mac) 80 | ((eq? head 'defreader) 'reader)) 81 | (document it (nth 1 x) (nth 2 x))))) 82 | 83 | (mysub (each-expr sub) 84 | (with loop (lambda (next) 85 | (when (not (eof? next)) 86 | (sub next) 87 | (loop (read)))) 88 | (loop (read)))) 89 | 90 | (mysub (document-file fname) 91 | (in-reg 92 | (with-var *current-file* (str+ fname ".html") 93 | (to-index-dst 94 | (say "\n\n## " fname "\n\n")) 95 | (with-file-dst (str+ fname ".md") 96 | (say "# " fname "\n\n") 97 | (with-file-src fname 98 | (each-expr look-at-expr))) 99 | ()))) 100 | 101 | (to-index-dst 102 | (say "# Bone Lisp " (bone-version))) 103 | 104 | (each document-file *files*) 105 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wolfgangj/bone-lisp/fc6290e97de81b1f28d81921182c6967a9911ec6/logo.png -------------------------------------------------------------------------------- /main.c: -------------------------------------------------------------------------------- 1 | /* main.c -- Entry point for standalone Bone Lisp interpreter. 2 | * Copyright (C) 2016 Wolfgang Jaehrling 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | */ 16 | 17 | #include 18 | #include "bone.h" 19 | #include "boneposix.h" 20 | 21 | int main(int argc, char **argv) { 22 | bone_init(argc, argv); 23 | bone_posix_init(); 24 | bone_load("prelude"); 25 | bone_load("posixprelude"); 26 | if (argc > 1) { 27 | try { 28 | bone_load(argv[1]); 29 | } catch { 30 | return 1; 31 | } 32 | return 0; 33 | } 34 | printf("Bone Lisp " BONE_VERSION); 35 | bone_repl(); 36 | return 0; 37 | } 38 | 39 | -------------------------------------------------------------------------------- /posix.bn: -------------------------------------------------------------------------------- 1 | ;;;; posix.bn -- Documentation for Bone Lisp POSIX operations. -*- lisp -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | ;;;; Note: This file contains only the documentation for the POSIX interface. 17 | 18 | (defsub (sys.errno) 19 | "Return the last error number after a failed syscall.") 20 | 21 | (defsub (sys.errname?) 22 | "Return a sym representing the last error after a failed syscall. 23 | 24 | This sub returns syms like `EACCES` and `EINVAL` so that you can check 25 | for certain error types by name. If the error in not known, it will 26 | return `#f`.") 27 | 28 | (defsub (sys.getpid) 29 | "Return the current process id.") 30 | 31 | (defsub (sys.getuid) 32 | "Return the current (non-effective) user id.") 33 | 34 | (defsub (sys.geteuid) 35 | "Return the current (effective) user id.") 36 | 37 | (defsub (sys.getgid) 38 | "Return the current (non-effective) group id.") 39 | 40 | (defsub (sys.getegid) 41 | "Return the current (effective) group id.") 42 | 43 | (defsub (sys.getenv? name) 44 | "Return the value currently associated with the environment variable `name`. 45 | 46 | `name` may be either a str or a sym.") 47 | 48 | (defsub (sys.setenv? name val overwrite?) 49 | "Set the value associated with the environment variable `name` to `val`. 50 | 51 | `name` may be either a str or a sym.") 52 | 53 | (defsub (sys.chdir? dir) 54 | "Change current working directory to `dir`.") 55 | 56 | (defsub (sys.getcwd?) 57 | "Return the current working directory.") 58 | 59 | (defsub (sys.time?) 60 | "Return seconds since epoch.") 61 | 62 | (defsub (sys.ctime? t) 63 | "Convert seconds since epoch into readable str representation of date and time.") 64 | 65 | (defsub (sys.gettimeofday?) 66 | "Return a list `(seconds microseconds)` of the time since epoch.") 67 | 68 | (defsub (sys.mkdir? dir mode) 69 | "Create the directory `dir` with permissions as specified by `mode`.") 70 | 71 | (defsub (sys.rmdir? dir) 72 | "Remove directory `dir` (which must be empty).") 73 | 74 | (defsub (sys.link? origin new) 75 | "Create the hard link `new` with the same inode as `origin`.") 76 | 77 | (defsub (sys.symlink? dest link) 78 | "Create a symbolic link from `link` to `dest`.") 79 | 80 | (defsub (sys.rename? old new) 81 | "Rename file `old` to `new`.") 82 | 83 | (defsub (sys.unlink? file) 84 | "Remove the `file`.") 85 | 86 | (defsub (sys.chmod? file mode) 87 | "Change permissions of `file` to `mode`.") 88 | 89 | (defsub (sys.umask mask) 90 | "Set the umask to `mask` and return the previous umask.") 91 | 92 | (defsub (sys.dir-entries? dir) 93 | "Return a sorted list of the files in `dir`.") 94 | 95 | (defsub (sys.kill? pid sig) 96 | "Send signal `sig` to process `pid`.") 97 | 98 | (defsub (sys.exit val) 99 | "Exit normally with status code `val`.") 100 | 101 | (defsub (sys.fork?) 102 | "Fork a child process; returns `0` in child, pid in parent, or `#f` on error.") 103 | 104 | (defsub (sys.waitpid? pid options) 105 | "Wait for event in child process `pid`. 106 | 107 | See `waitpid(2)` syscall manpage for details on `pid`; for example, 108 | passing `-1` will wait for any child process. The return value is a 109 | list of the pid and the status. The status can be analized with 110 | `sys.exitstatus?`, `sys.termsig?`, `sys.stopsig?` and `sys.continued`. 111 | 112 | We don't provide symbolic constants for `options` yet, so you should 113 | pass `0`.") 114 | 115 | (defsub (sys.exitstatus? status) 116 | "If the child terminated normally, return its exit status; `#f` otherwise. 117 | 118 | `status` should be a value that was returned by `sys.waitpid?`.") 119 | 120 | (defsub (sys.termsig? status) 121 | "If the child was terminated by a signal, return the signal number; `#f` otherwise. 122 | 123 | `status` should be a value that was returned by `sys.waitpid?`.") 124 | 125 | (defsub (sys.stopsig? status) 126 | "If the child was stopped by a signal, return the signal number; `#f` otherwise. 127 | 128 | `status` should be a value that was returned by `sys.waitpid?`.") 129 | 130 | (defsub (sys.continued? status) 131 | "Return whether the child was continued with `SIGCONT`. 132 | 133 | `status` should be a value that was returned by `sys.waitpid?`.") 134 | 135 | (defsub (sys.random n) 136 | "Return a random number in the range from 0 to `n`-1.") 137 | 138 | (defsub (sys.src-open? fname) 139 | "Attempt to open the file `fname` as a src.") 140 | 141 | (defsub (sys.src-close? src) 142 | "Close the `src`.") 143 | 144 | (defsub (sys.dst-open? fname) 145 | "Attempt to open the file `fname` as a dst.") 146 | 147 | (defsub (sys.dst-close? dst) 148 | "Close the `src`.") 149 | 150 | (defsub (sys.execvp? prog args) 151 | "Replace current process with a call to `prog` with `args`. 152 | 153 | Note that `args` needs to contain at least the program name. 154 | 155 | This sub will search for `prog` in the `$PATH`.") 156 | 157 | (defsub (sys.strerror num) 158 | "Return a string describing system error `n`.") 159 | -------------------------------------------------------------------------------- /posixprelude.bn: -------------------------------------------------------------------------------- 1 | ;;;; posixprelude.bn -- Wrappers for POSIX functions -*- bone -*- 2 | ;;;; Copyright (C) 2016 Dov Murik 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (internsub (_posix-err name) 17 | (err "Error calling POSIX " name ": " (sys.strerror (sys.errno)))) 18 | 19 | (defsub (gettimeofday) 20 | "Return a list `(seconds microseconds)` of the time since epoch." 21 | (aif (sys.gettimeofday?) 22 | it 23 | (_posix-err "gettimeofday"))) 24 | 25 | (defsub (timeofday-diff t2 t1) 26 | "Return the number of microseconds between `t1` and `t2`, which are both 27 | two-element lists of the form `(sec usec)` (as returned from `gettimeofday`)." 28 | (let ((t1-sec (car t1)) 29 | (t1-usec (cadr t1)) 30 | (t2-sec (car t2)) 31 | (t2-usec (cadr t2))) 32 | (+ (* 1000000 (- t2-sec t1-sec)) (- t2-usec t1-usec)))) 33 | 34 | (defsub (str-now) 35 | "Return a str describung the current time." 36 | (with t (sys.time?) 37 | (aif (and t (sys.ctime? t)) 38 | (str-dropr 1 it) 39 | (_posix-err "time or ctime")))) 40 | 41 | (defsub (wait-for pid) 42 | "Wait for child `pid` to terminate. 43 | 44 | Returns a negative number for termination by signals, otherwise the exit status." 45 | (with loop (lambda () 46 | (with status (cadr? (sys.waitpid? pid 0)) 47 | (acond ((not status) (_posix-err "waitpid")) 48 | ((sys.exitstatus? status) it) 49 | ((sys.termsig? status) (- 0 it)) 50 | (#t (loop))))) 51 | (loop))) 52 | 53 | (defsub (exec prog . args) 54 | "Replace current program by calling `prog` with `args`." 55 | (or (sys.execvp? prog (cons prog args)) 56 | (_posix-err "execvp"))) 57 | 58 | (defsub (call prog . args) 59 | "Call the program `prog` with `args` and returns its exit status or (negative) termination signal." 60 | (aif (sys.fork?) 61 | (if (0? it) 62 | (apply exec prog args) 63 | (wait-for it)) 64 | (_posix-err "fork"))) 65 | 66 | (defsub (system cmd) 67 | "Start the shell command `cmd` and return its exit status." 68 | (call "/bin/sh" "-c" cmd)) 69 | -------------------------------------------------------------------------------- /prelude.bn: -------------------------------------------------------------------------------- 1 | ;;;; prelude.bn -- Basic definitions of Bone Lisp. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | ;; Need this first because quasiquote expands to it 17 | (_bind 'cat #f _full-cat) 18 | (_mac-bind 'cat #f 19 | (lambda args 20 | (cons (if (_fast=? 2 (len args)) '_fast-cat '_full-cat) args))) 21 | 22 | (_bind '_make-nonrecursive-binder #t 23 | (lambda (binder spec body overwritable) 24 | `(,binder ',(car spec) ,overwritable 25 | (lambda ,(cdr spec) ,@body)))) 26 | 27 | (_bind '_make-recursive-binder #t 28 | (lambda (binder spec body overwritable) 29 | `(with ,(car spec) (lambda ,(cdr spec) ,@body) 30 | (,binder ',(car spec) ,overwritable ,(car spec))))) 31 | 32 | (_bind '_make-binder-without-lambda #t 33 | (lambda (binder name body overwritable) 34 | (if (not (single? body)) 35 | (err "too many expressions in definition of " name) 36 | `(,binder ',name ,overwritable ,(car body))))) 37 | 38 | (_bind '_make-binder #t 39 | (lambda (binder spec body overwritable) 40 | ((if (sym? spec) 41 | _make-binder-without-lambda 42 | (if (not (_refers-to? body (car spec))) 43 | _make-nonrecursive-binder 44 | _make-recursive-binder)) 45 | binder spec body overwritable))) 46 | 47 | ;; FIXME: defmac has no docstring... 48 | (_mac-bind 'defmac #f 49 | (lambda (spec doc . body) 50 | (if (not (str? doc)) 51 | (err "`defmac` requires a docstring - " (car spec)) 52 | (_make-binder '_mac-bind spec body #f)))) 53 | 54 | (defmac (defsub spec doc . body) 55 | "Define a sub with name/args as in `spec`, docstring `doc` and code `body`." 56 | (if (not (str? doc)) 57 | (err "`defsub` requires a docstring - " (car spec)) 58 | (_make-binder '_bind spec body #f))) 59 | 60 | (defmac (internmac spec . body) 61 | "Define an internal macro." 62 | (_make-binder '_mac-bind spec body #f)) 63 | 64 | (defmac (internsub spec . body) 65 | "Define an internal sub." 66 | (_make-binder '_bind spec body #f)) 67 | 68 | (defmac (mymac spec . body) 69 | "Define a locally used mac." 70 | (_make-binder '_mac-bind spec body #t)) 71 | 72 | (defmac (mysub spec . body) 73 | "Define a locally used sub." 74 | (_make-binder '_bind spec body #t)) 75 | 76 | (defmac (defreader name doc . body) 77 | "Register the reader macro `name` with code `body`; docstring being `doc`." 78 | `(_reader-bind ',name #f (lambda () ,@body))) 79 | 80 | (defmac (myreader name . body) 81 | "Register the locally used reader macro `name` with code `body`." 82 | `(_reader-bind ',name #t (lambda () ,@body))) 83 | 84 | (defmac (declare name) 85 | "Announce that `name` will be defined later. 86 | 87 | It will be possible for code to refer to the binding before its 88 | definition, but it has to be defined before that code is being run. 89 | This is intended for making mutual recursion of subs possible." 90 | `(_declare ',name)) 91 | 92 | (internsub (_every-pair? compare? xs) 93 | (with loop (lambda (xs) 94 | (if (single? xs) 95 | #t 96 | (if (compare? (car xs) (car (cdr xs))) (loop (cdr xs))))) 97 | (if (nil? xs) #t (loop xs)))) 98 | 99 | (internsub (_full=? . xs) (_every-pair? _fast=? xs)) 100 | (internsub (_full>? . xs) (_every-pair? _fast>? xs)) 101 | (internsub (_full=? . xs) (_every-pair? _fast>=? xs)) 103 | (internsub (_full<=? . xs) (_every-pair? _fast<=? xs)) 104 | 105 | (internmac (_optimize name binary n-ary) 106 | `(internmac (,name . args) 107 | (cons (if (_fast=? 2 (len args)) ',binary ',n-ary) args))) 108 | 109 | (_optimize + _fast+ _full+) 110 | (_optimize - _fast- _full-) 111 | (_optimize * _fast* _full*) 112 | (_optimize / _fast/ _full/) 113 | (_optimize =? _fast=? _full=?) 114 | (_optimize >? _fast>? _full>?) 115 | (_optimize =? _fast>=? _full>=?) 117 | (_optimize <=? _fast<=? _full<=?) 118 | ;(_optimize cat _fast-cat _full-cat) ; did this earlier 119 | (_optimize append _fast-cat _full-cat) 120 | (_optimize list+ _fast-cat _full-cat) 121 | 122 | (defsub (caar x) "The `car` of the `car` of `x`." (car (car x))) 123 | (defsub (cadr x) "The `car` of the `cdr` of `x`." (car (cdr x))) 124 | (defsub (cdar x) "The `cdr` of the `car` of `x`." (cdr (car x))) 125 | (defsub (cddr x) "The `cdr` of the `cdr` of `x`." (cdr (cdr x))) 126 | (defsub (caaar x) "The `car` of the `car` of the `car` of `x`." (caar (car x))) 127 | (defsub (caadr x) "The `car` of the `car` of the `cdr` of `x`." (caar (cdr x))) 128 | (defsub (cadar x) "The `car` of the `cdr` of the `car` of `x`." (cadr (car x))) 129 | (defsub (caddr x) "The `car` of the `cdr` of the `cdr` of `x`." (cadr (cdr x))) 130 | (defsub (cdaar x) "The `cdr` of the `car` of the `car` of `x`." (cdar (car x))) 131 | (defsub (cdadr x) "The `cdr` of the `car` of the `cdr` of `x`." (cdar (cdr x))) 132 | (defsub (cddar x) "The `cdr` of the `cdr` of the `car` of `x`." (cddr (car x))) 133 | (defsub (cdddr x) "The `cdr` of the `cdr` of the `cdr` of `x`." (cddr (cdr x))) 134 | 135 | (defmac (cond . clauses) 136 | "Shortcut for nested `if` clauses. 137 | 138 | Each clause in `clauses` is of the form `(condition . body)`. The 139 | clauses are processed in order. The condition of a clause is 140 | evaluated and if it gives a true value, all the expressions in the 141 | body are evaluated; no further clauses will be processed in this case. 142 | If the condition was false, however, the next clause will be 143 | processed in the same way. If no condition was true, `#f` will be 144 | returned. 145 | 146 | It is common to have an else-clause in the end which has `#t` as its 147 | condition." 148 | (if (nil? clauses) 149 | #f 150 | (if (eq? #t (caar clauses)) 151 | `(do ,@(cdar clauses)) 152 | `(if ,(caar clauses) 153 | (do ,@(cdar clauses)) 154 | (cond ,@(cdr clauses)))))) 155 | 156 | (defmac (and . args) 157 | "Logical short-circuit AND. 158 | 159 | The `args` are evaluated in order until one yields `#f`, in which case 160 | `#f` will also be returned. Otherwise, the result of the last argument 161 | will be returned." 162 | (cond ((nil? args) #t) 163 | ((nil? (cdr args)) (car args)) 164 | (#t `(if ,(car args) (and ,@(cdr args)) #f)))) 165 | 166 | (defmac (or . args) 167 | "Logical short-circuit OR. 168 | 169 | The `args` are evaluated in order until one yields a true value, in 170 | which case it will also be returned. Otherwise, `#f` will be 171 | returned." 172 | (cond ((nil? args) #f) 173 | ((nil? (cdr args)) (car args)) 174 | (#t `(if ,(car args) (do) (or ,@(cdr args)))))) 175 | 176 | (defmac (when expr . body) 177 | "When `expr` is true, evaluate all expressions in `body`." 178 | `(if ,expr (do ,@body) #f)) 179 | 180 | (defmac (let bindings . body) 181 | "Shortcut for nested `with`: Introduce several `bindings` at once. 182 | 183 | The `bindings` are of the form `(name value)`." 184 | (if (nil? bindings) 185 | (cons 'do body) 186 | `(with ,(caar bindings) ,(cadar bindings) (let ,(cdr bindings) . ,body)))) 187 | 188 | (defmac (aif expr then . else) 189 | "Anamorphic `if`: Bind `it` to the result of `expr`." 190 | `(with it ,expr (if it ,then ,@else))) 191 | 192 | (defmac (awhen expr . body) 193 | "Anamorphic `when`: Bind `it` to the result of `expr`." 194 | `(with it ,expr (when it ,@body))) 195 | 196 | (defmac (acond . clauses) 197 | "Anamorphic version of `cond`: Bind `it` to the result of the condition." 198 | (if (nil? clauses) 199 | #f 200 | (if (eq? #t (caar clauses)) 201 | `(do ,@(cdar clauses)) 202 | `(aif ,(caar clauses) 203 | (do ,@(cdar clauses)) 204 | (acond ,@(cdr clauses)))))) 205 | 206 | (defmac (with-gensyms names . body) 207 | "Bind all of `names` to `gensym`s and evaluate `body`." 208 | `(let ,(map (lambda (name) 209 | `(,name (gensym))) 210 | names) 211 | ,@body)) 212 | 213 | (defmac (destructure bindings val . body) 214 | "Bind a list of `bindings` to the list `val`, thereby destructuring it." 215 | (with-gensyms (lst) 216 | `(with ,lst ,val 217 | (with ,(car bindings) (car ,lst) 218 | ,(if (nil? (cdr bindings)) 219 | (cons 'do body) 220 | `(destructure ,(cdr bindings) (cdr ,lst) ,@body)))))) 221 | 222 | (defsub (equal? a b) 223 | "Compare `a` and `b` for structural equality." 224 | (cond ((str? a) (and (str? b) 225 | (str=? a b))) 226 | ((cons? a) (and (cons? b) 227 | (equal? (car a) (car b)) 228 | (equal? (cdr a) (cdr b)))) 229 | (#t (eq? a b)))) 230 | 231 | (defmac (case val . clauses) 232 | "Choose one of the `clauses` depending on the `val`ue. 233 | 234 | A clause is a list with the first element being a list of values 235 | matched against `val`. It may also have `#t` as first element instead 236 | of the value list, in which case the branch is always taken." 237 | (with-gensyms (x) 238 | `(with ,x ,val 239 | (cond ,@(map (lambda (clause) 240 | (cons (if (eq? #t (car clause)) 241 | #t 242 | `(or ,@(map (lambda (candidate) 243 | `(equal? ,x ',candidate)) 244 | (car clause)))) 245 | (cdr clause))) 246 | clauses))))) 247 | 248 | (defsub (compose sub1 sub2) 249 | "Return a sub that calls `sub2` with its arguments, then `sub1` on the result." 250 | (lambda args 251 | (sub1 (apply sub2 args)))) 252 | 253 | (defsub (partial sub . args) 254 | "Partially apply `args` to `sub`." 255 | (if (single? args) 256 | (with arg (car args) ; fast path 257 | (lambda more-args 258 | (apply sub arg more-args))) 259 | (lambda more-args 260 | (apply sub (cat args more-args))))) 261 | 262 | (defmac (rlambda name args . body) 263 | "Like `lambda`, but also binds `name` to the sub itself." 264 | `(with ,name (lambda ,args ,@body) ,name)) 265 | 266 | (defmac (in-reg . body) 267 | "Evaluate `body` while using a new memory region; copy back the result." 268 | `(_in-reg (lambda () ,@body))) 269 | 270 | (defmac (reg-loop init loop) 271 | "Evaluate `body` repeatedly in a new region, passing its result as args to the next iteration. 272 | 273 | First, `init` will be evaluated in a new region. This new region will 274 | be freed after copying the result to a another new region. We apply 275 | that result to the sub `loop` (while using the second new region). It 276 | is expected to return a list with an indicator in its car that decides 277 | whether we want to continue the iteration (with `#f` meaning that we 278 | should not continue). The rest of the list will either be used as the 279 | return value, or applied to `loop` in the next iteration after copying 280 | to a new region and freeing the previous region. Example: 281 | 282 | (reg-loop (list 1 2 3) 283 | | a b c (cons (x next-seed seed) 345 | "Unfold a list. 346 | 347 | The list is generated by creating values with `seed->x`, updating the 348 | seed with `next-seed` and `stop?` telling us to finish." 349 | (with next (lambda (seed) 350 | (if (stop? seed) 351 | () 352 | (cons (seed->x seed) 353 | (next (next-seed seed))))) 354 | (next seed))) 355 | 356 | (defsub (unfoldr stop? seed->x next-seed seed) 357 | "Unfold a list from the right. 358 | 359 | The list is generated by creating values with `seed->x`, updating the 360 | seed with `next-seed` and `stop?` telling us to finish." 361 | (with loop (lambda (seed so-far) 362 | (if (stop? seed) 363 | so-far 364 | (loop (next-seed seed) 365 | (cons (seed->x seed) so-far)))) 366 | (loop seed ()))) 367 | 368 | (defsub (0? n) 369 | "Check whether the number `n` is zero." 370 | (=? 0 n)) 371 | 372 | (defsub (>0? n) 373 | "Check whether the number `n` is positive." 374 | (>? n 0)) 375 | 376 | (defsub (<0? n) 377 | "Check whether the number `n` is negative." 378 | (float n) 399 | "Return a floating-point number equal to integer `n`." 400 | (+ 0.0 n)) 401 | 402 | (defsub (xcons d a) 403 | "Like `cons`, but order of arguments is reversed. 404 | 405 | This can be useful for passing to higher order functions." 406 | (cons a d)) 407 | 408 | (defsub (cat-lists xs) 409 | "Concatenate all the lists in `xs` together." 410 | (apply cat xs)) 411 | 412 | (defsub (nth-cons n xs) 413 | "Return the `n`th cons of `xs` (starting at 0), which must have enough conses." 414 | (if (0? n) 415 | xs 416 | (nth-cons (-- n) (cdr xs)))) 417 | 418 | (defsub (nth n xs) 419 | "Return the `n`th element of `xs`." 420 | (car (nth-cons n xs))) 421 | 422 | (defsub (drop n xs) 423 | "Return the `n`th cons of `xs` (or nil if `xs` is shorter than `n`)." 424 | (if (or (0? n) (nil? xs)) 425 | xs 426 | (drop (-- n) (cdr xs)))) 427 | 428 | (defsub (take n xs) 429 | "Return the first `n` elements of `xs` (or all of `xs` if it has less than `n` elements)." 430 | (if (or (0? n) (nil? xs)) 431 | () 432 | (cons (car xs) 433 | (take (-- n) (cdr xs))))) 434 | 435 | (defsub (dropr n xs) 436 | "Drop the `n` elements from the end of `xs`." 437 | (with cnt (- (len xs) n) 438 | (if (<0? cnt) 439 | () 440 | (take cnt xs)))) 441 | 442 | (defsub (taker n xs) 443 | "Take the `n` last elements from `xs` (or all of `xs` if it has less than `n` elements)." 444 | (with cnt (- (len xs) n) 445 | (if (<0? cnt) 446 | xs 447 | (drop cnt xs)))) 448 | 449 | (defsub (last xs) 450 | "Return the last value in the list `xs`." 451 | (car (taker 1 xs))) 452 | 453 | (defsub (find? is? xs) 454 | "Return the first element in `xs` that satisfies predicate `is?`." 455 | (with loop (lambda (xs) 456 | (cond ((nil? xs) #f) 457 | ((is? (car xs)) (car xs)) 458 | (#t (loop (cdr xs))))) 459 | (loop xs))) 460 | 461 | (defsub (any? is? xs) 462 | "Return whether any element of `xs` satisfies predicate `is?`." 463 | (with loop (lambda (xs) 464 | (cond ((nil? xs) #f) 465 | ((is? (car xs)) #t) 466 | (#t (loop (cdr xs))))) 467 | (loop xs))) 468 | 469 | (defsub (all? is? xs) 470 | "Return whether any element of `xs` satisfies predicate `is?`." 471 | (with loop (lambda (xs) 472 | (cond ((nil? xs) #t) 473 | ((not (is? (car xs))) #f) 474 | (#t (loop (cdr xs))))) 475 | (loop xs))) 476 | 477 | (defsub (flatten xs) 478 | "Turn the tree `xs` into a list." 479 | (cat-lists (map (lambda (x) 480 | (cond ((cons? x) (flatten x)) 481 | ((nil? x) ()) 482 | (#t (list x)))) 483 | xs))) 484 | 485 | (defsub (car? x) 486 | "If `x` is a cons, return its car, otherwise return `#f`." 487 | (and (cons? x) (car x))) 488 | 489 | (defsub (cdr? x) 490 | "If `x` is a cons, return its cdr, otherwise return `#f`." 491 | (and (cons? x) (cdr x))) 492 | 493 | (defsub (caar? x) "The `car?` of the `car?` of `x`." (car? (car? x))) 494 | (defsub (cadr? x) "The `car?` of the `cdr?` of `x`." (car? (cdr? x))) 495 | (defsub (cdar? x) "The `cdr?` of the `car?` of `x`." (cdr? (car? x))) 496 | (defsub (cddr? x) "The `cdr?` of the `cdr?` of `x`." (cdr? (cdr? x))) 497 | 498 | (defsub (car* x) 499 | "If `x` is a cons, return its car; otherwise, return nil." 500 | (if (cons? x) (car x) ())) 501 | 502 | (defsub (cdr* x) 503 | "If `x` is a cons, return its cdr; otherwise, return nil." 504 | (if (cons? x) (cdr x) ())) 505 | 506 | (defsub (caar* x) "The `car*` of the `car*` of `x`." (car* (car* x))) 507 | (defsub (cadr* x) "The `car*` of the `cdr*` of `x`." (car* (cdr* x))) 508 | (defsub (cdar* x) "The `cdr*` of the `car*` of `x`." (cdr* (car* x))) 509 | (defsub (cddr* x) "The `cdr*` of the `cdr*` of `x`." (cdr* (cdr* x))) 510 | 511 | (defsub (assocar? key alist) 512 | "Get the first value of the list associated with `key` in `alist` (or `#f` if `key` not in `alist`)." 513 | (car? (assoc? key alist))) 514 | 515 | (defsub (acons key value alist) 516 | "Put `(key value)` in front of the `alist`." 517 | (cons (list key value) alist)) 518 | 519 | (defsub (str-len s) 520 | "The number of characters in the str `s`." 521 | (len (unstr s))) 522 | 523 | (defsub (str-nth n s) 524 | "Return the `n`th character in string `s`." 525 | (nth n (unstr s))) 526 | 527 | (defsub (str+ . strs) 528 | "Concatenate all the `strs`." 529 | (str (cat-lists (map unstr strs)))) 530 | 531 | (defsub (str-drop n s) 532 | "Return str `s` without the first `n` characters." 533 | (str (drop n (unstr s)))) 534 | 535 | (defsub (str-take n s) 536 | "Return a str containing the first `n` characters of `s` (or all of `s` if it's shorter)." 537 | (str (take n (unstr s)))) 538 | 539 | (defsub (str-dropr n s) 540 | "Return str `s` without the first `n` characters." 541 | (str (dropr n (unstr s)))) 542 | 543 | (defsub (str-taker n s) 544 | "Return a str containing the first `n` characters of `s` (or all of `s` if it's shorter)." 545 | (str (taker n (unstr s)))) 546 | 547 | (defsub (str-suffix? suffix string) 548 | "Check whether the str `string` ends in `suffix`." 549 | (str=? suffix (str-taker (str-len suffix) string))) 550 | 551 | (defsub (str-prefix? prefix string) 552 | "Check whether `string` starts with `prefix`." 553 | (str=? prefix (str-take (str-len prefix) string))) 554 | 555 | (defsub (str-empty? s) 556 | "Check whether str `s` is the empty str." 557 | (str=? "" s)) 558 | 559 | (defsub (str-select from to s) 560 | "Extract the middle part of the str `s`, bounds being `from` and `to`." 561 | (str-take (- to from) 562 | (str-drop from s))) 563 | 564 | (defsub (str-join separator . strs) 565 | "Concatenate `strs` with `separator` between each str." 566 | (apply str+ (cdr* (foldr (lambda (s so-far) 567 | (list* separator s so-far)) 568 | () 569 | strs)))) 570 | 571 | ;; FIXME: this is not very efficient 572 | (defsub (str-pos? needle haystack) 573 | "Return the position (zero-based) of `needle` in `haystack` (or `#f` if not found)." 574 | (with loop (lambda (pos s) 575 | (cond ((str-empty? s) #f) 576 | ((str-prefix? needle s) pos) 577 | (#t (loop (++ pos) (str (cdr (unstr s))))))) 578 | (loop 0 haystack))) 579 | 580 | (defsub (str* n s) 581 | "Concatenate the str `s` `n` times." 582 | (apply str+ (unfold 0? (lambda (x) s) -- n))) 583 | 584 | (defsub (str-pad n s) 585 | "Add spaces to the left side of `s` until it is `n` characters long." 586 | (with l (str-len s) 587 | (if (>=? l n) 588 | s 589 | (str+ (str* (- n l) " ") s)))) 590 | 591 | (defsub (str-padr n s) 592 | "Add spaces to the right side of `s` until it is `n` characters long." 593 | (with l (str-len s) 594 | (if (>=? l n) 595 | s 596 | (str+ s (str* (- n l) " "))))) 597 | 598 | (defsub (str-subst old-needle new-needle haystack) 599 | "Replace `old-needle` with `new-needle` in `haystack` (all of them are strs). 600 | 601 | If `old-needle` is not in `haystack`, just returns `haystack` 602 | unmodified. Note that only one occurrence of `old-needle` will be 603 | replaced. If you want to replace all occurrences, use `str-gsubst` 604 | instead." 605 | (aif (str-pos? old-needle haystack) 606 | (str+ (str-take it haystack) 607 | new-needle 608 | (str-drop (+ (str-len old-needle) it) 609 | haystack)) 610 | haystack)) 611 | 612 | (defsub (str-gsubst old-needle new-needle haystack) 613 | "Replace all occurrences of `old-needle` with `new-needle` in `haystack` (all strs)." 614 | (with loop (lambda (remain) 615 | (aif (str-pos? old-needle remain) 616 | (str+ (str-take it remain) 617 | new-needle 618 | (loop (str-drop (+ (str-len old-needle) it) 619 | remain))) 620 | remain)) 621 | (loop haystack))) 622 | 623 | (defsub (chr-skip ignore consume) 624 | "Read up to a character not in `ignore`, return that character (via `chr-look` if `consume` is false)." 625 | (with loop (lambda () 626 | (if (not (member? (chr-look) 627 | (unstr ignore))) 628 | (if consume (chr-read) (chr-look)) 629 | (do (chr-read) 630 | (loop)))) 631 | (loop))) 632 | 633 | (defreader eval 634 | "Evaluate the next expression at read-time." 635 | (eval (read))) 636 | 637 | (defreader chr 638 | "Get the code point of a character; should be followed by a 1-character str" 639 | (with s (read) 640 | (if (or (not (str? s)) 641 | (<>? 1 (str-len s))) 642 | (err "chr reader requires a 1-character str") 643 | (car (unstr s))))) 644 | 645 | (defsub (read-line) 646 | "Read a line; the returned str will not contain the newline." 647 | (str (unfold | c (=? c #chr "\n") 648 | id 649 | | c (chr-read) 650 | (chr-read)))) 651 | 652 | (defsub (str-ascii-lower s) 653 | "Convert upper case characters in `s` to lower case. 654 | 655 | This is useful e.g. for checking file extensions case independently. 656 | Note that there is no corresponding `str-ascii-upper`." 657 | (str (map (lambda (c) 658 | (if (not (<=? #chr "A" c #chr "Z")) 659 | c 660 | (+ c (- #chr "a" #chr "A")))) 661 | (unstr s)))) 662 | 663 | ;;;; Aliases 664 | 665 | (defmac (alias new old) 666 | "Define `new` as an alias for sub `old`." 667 | `(_bind ',new #f ,old)) 668 | 669 | (alias + _full+) 670 | (alias no nil?) 671 | (alias list->str str) 672 | (alias str->list unstr) 673 | (alias length len) 674 | (alias size len) 675 | (alias str->sym intern) 676 | (alias unintern sym->str) 677 | (alias - _full-) 678 | (alias * _full*) 679 | (alias / _full/) 680 | (alias cons* list*) 681 | (alias contains? member?) 682 | (alias modulo mod) 683 | (alias % mod) 684 | (alias =? _full=?) 685 | (alias >? _full>?) 686 | (alias =? _full>=?) 688 | (alias <=? _full<=?) 689 | (alias macroexpand-1 mac-expand-1) 690 | (alias macroexpand mac-expand) 691 | (alias append cat) 692 | (alias list+ cat) 693 | (alias =0? 0?) 694 | (alias zero? 0?) 695 | (alias positive? >0?) 696 | (alias negative? <0?) 697 | (alias str-cat str+) 698 | (alias str-append str+) 699 | (alias head car) 700 | (alias tail cdr) 701 | (alias str-nil? str-empty?) 702 | (alias foldl fold) 703 | (alias fold-left fold) 704 | (alias fold-right foldr) 705 | (alias unfoldl unfold) 706 | (alias unfold-left unfold) 707 | (alias unfold-right unfoldr) 708 | (alias drop-right dropr) 709 | (alias take-right taker) 710 | (alias str-drop-right str-dropr) 711 | (alias str-take-right str-taker) 712 | (alias every? all?) 713 | (alias for-each each) 714 | (alias str-contains? str-pos?) 715 | (alias str-padl str-pad) 716 | (alias str-pad-left str-pad) 717 | (alias str-pad-right str-padr) 718 | (alias float->int trunc) 719 | (alias str-replace str-subst) 720 | 721 | ;;;; Implementation information 722 | 723 | (defsub (lisp-info item) 724 | "Get implementation information about `item`." 725 | (assocar? item _*lisp-info*)) 726 | 727 | (defsub (version major minor) 728 | "Declare that the following code is compatible with interpreter version `major`.`minor`." 729 | (when (not (and (=? major (lisp-info 'major-version)) 730 | (<=? minor (lisp-info 'minor-version)))) 731 | (err "code is not compatible with implementation version"))) 732 | 733 | ;;;; Modules 734 | 735 | (defvar _*incomplete-mods* ()) 736 | (defvar _*complete-mods* ()) 737 | 738 | (internsub (_use-mod mod) 739 | (cond ((member? mod _*complete-mods*) #t) 740 | ((member? mod _*incomplete-mods*) 741 | (err "ERR: recursive module inclusion\n")) 742 | (#t (with-var _*incomplete-mods* (cons mod _*incomplete-mods*) 743 | (_load mod)) 744 | (_var! '_*complete-mods* (_pcons mod _*complete-mods*))))) 745 | 746 | (defmac (use . mods) 747 | "Use the modules listed in `mods`." 748 | `(each _use-mod ',mods)) 749 | 750 | (defmac (reload mod) 751 | "Load the module `mod`; existing bindings can be overwritten by it." 752 | `(_reload ',mod)) 753 | -------------------------------------------------------------------------------- /std/alist.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/alist.bn -- Standard association list library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defsub (simplify-alist alist) 17 | "Remove all redundant entries from `alist`." 18 | (fold (lambda (entry so-far) 19 | (if (assoc? (car entry) so-far) 20 | so-far 21 | (cons entry so-far))) 22 | () 23 | alist)) 24 | 25 | (mysub (_read-alist) 26 | (if (=? (chr-skip " \n\t" #f) #chr")") 27 | (do (chr-read) ; skip past ")" 28 | ()) 29 | (with key (read) 30 | (if (<>? (chr-skip " \n\t" #t) #chr":") 31 | (err "invalid alist notation: expected `:`.") 32 | (cons (list key (read)) 33 | (_read-alist)))))) 34 | 35 | (defreader => 36 | "Convenient notation for association lists. 37 | 38 | For example, `#=>(foo:(+ 1 2) bar:0)` expands to `((foo (+ 1 2)) (bar 0))`." 39 | (if (<>? (chr-skip " \n\t" #t) #chr"(") 40 | (err "invalid alist notation: expected `(`.") 41 | (_read-alist))) 42 | 43 | -------------------------------------------------------------------------------- /std/bases.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/bases.bn -- Standard positional numeral systems library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (mysub (_chr->val c) 17 | (cond ((<=? #chr "0" c #chr "9") (- c #chr "0")) 18 | ((<=? #chr "a" c #chr "z") (+ (- c #chr "a") 10)) 19 | ((<=? #chr "A" c #chr "Z") (+ (- c #chr "A") 10)) 20 | (#t #f))) 21 | 22 | (mysub (_valid-in-base? base n) 23 | (val (chr-look)) 37 | (if (or (not val) 38 | (not (_valid-in-base? base val))) 39 | so-far 40 | (do (chr-read) ; it was valid, so remove it from src 41 | (loop (+ (* base so-far) val)))))) 42 | (* sign (loop 0))))) 43 | 44 | (defreader bin 45 | "Read a number in base two (binary)." 46 | (_read-in-base 2)) 47 | 48 | (defreader oct 49 | "Read a number in base eight (octal)." 50 | (_read-in-base 8)) 51 | 52 | (defreader hex 53 | "Read a number in base sixteen (hexadecimal)." 54 | (_read-in-base 16)) 55 | 56 | (defreader in-base 57 | "Read a number in the given base." 58 | (_read-in-base (read))) 59 | -------------------------------------------------------------------------------- /std/bench.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/bench.bn -- Benchmark library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Dov Murik 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defsub (measure-time f) 17 | "Execute `f` (function with no arguments) and return the number of microseconds elapsed." 18 | (with start-time (gettimeofday) 19 | (f) 20 | (timeofday-diff (gettimeofday) start-time))) 21 | 22 | (defmac (say-time f) 23 | "Execute `f` (any Bone Lisp expression) and print the time it took. Example: 24 | 25 | (say-time (unfoldr =0? id -- 10000)) 26 | Running (unfoldr =0? id -- 10000) ... Elapsed: 15117 usecs" 27 | `(do 28 | (say "Running ") 29 | (print ',f) 30 | (say " ... ") 31 | (with elapsed (measure-time | ,f) 32 | (say "Elapsed: " elapsed " usecs\n")))) 33 | -------------------------------------------------------------------------------- /std/html.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/html.bn -- Standard HTML library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defsub (htmlize text) 17 | "Escape HTML characters in `text`. 18 | 19 | For example, all occurrences of `\"` will be replaced with `"`." 20 | (fold (lambda (subst text) 21 | (destructure (old new) subst 22 | (str-gsubst old new text))) 23 | text 24 | '(("&" "&") ; must be first 25 | ("<" "<") 26 | (">" ">") 27 | ("\"" """)))) 28 | 29 | -------------------------------------------------------------------------------- /std/log.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/log.bn -- Standard logging library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defvar _*log-dst* *stderr*) 17 | 18 | (defmac (with-log file . body) 19 | "Evaluate `body` while writing log entries to `file`." 20 | (with-gensyms (backup) 21 | `(with ,backup *dst* 22 | (with-file-dst ,file 23 | (with-var _*log-dst* *dst* 24 | (with-var *dst* ,backup ; restore 25 | ,@body)))))) 26 | 27 | (mysub (_log-timestamp) 28 | (when (lisp-info 'posix) 29 | (say (str-now) " "))) 30 | 31 | (defsub (log . data) 32 | "The last value in `data` will be logged with `print`, the others with `say`. 33 | 34 | Returns the last value." 35 | (let ((val (last data)) 36 | (msg (drop-right 1 data))) 37 | (with-var *dst* _*log-dst* 38 | (_log-timestamp) 39 | (say msg ": ") 40 | (print val) 41 | (say "\n")) 42 | val)) 43 | -------------------------------------------------------------------------------- /std/math.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/math.bn -- Standard math library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defsub (percent perc n) 17 | "Return `perc` percent of `n`." 18 | (/ (* 100 n) (/ 10000 perc))) 19 | 20 | (defsub (max . xs) 21 | "Return the maximum numeric value in `xs` (which may not be empty)." 22 | (fold (lambda (x so-far) 23 | (if (>? x so-far) x so-far)) 24 | (car xs) 25 | (cdr xs))) 26 | 27 | (defsub (min . xs) 28 | "Return the minimum numeric value in `xs` (which may not be empty)." 29 | (fold (lambda (x so-far) 30 | (if (0? step) >? ? (str-len arg) 1))) 52 | 53 | (mysub (_long-option? arg) 54 | (and (str-prefix? "--" arg) 55 | (>? (str-len arg) 2))) 56 | 57 | ;; Return the option-arg (or #f) 58 | (mysub (_option-arg? arg) 59 | (aif (str-pos? "=" arg) 60 | (str-drop (++ it) arg))) 61 | 62 | (mysub (_flag? sym opt-spec) 63 | (aif (assocar? sym opt-spec) 64 | (assocar? 'flag it))) 65 | 66 | (mysub (_extract-long-option arg opt-spec) 67 | (with given (aif (str-pos? "=" arg) 68 | (str-select 2 it arg) 69 | (str-drop 2 arg)) 70 | (if (assoc? given opt-spec) 71 | (intern given) 72 | (with matches (fold (lambda (new so-far) 73 | (if (str-prefix? given (sym->str new)) 74 | (cons new so-far) 75 | so-far)) 76 | () 77 | (map car opt-spec)) 78 | (case (len matches) 79 | ((0) (err "Unknown option: --" (intern given))) 80 | ((1) (car matches)) 81 | (#t (err "Ambigous option abbreviation: --" (intern given)))))))) 82 | 83 | (mysub (_short->long char opt-spec) 84 | (aif (car? (find? | opt (eq? char (assocar? 'short (cadr opt))) 85 | opt-spec)) 86 | it 87 | (err "Option unknown: -" (str (list char))))) 88 | 89 | (mysub (_parse-prog-args args options-spec) 90 | (with loop 91 | (lambda (remain options-result non-options-result) 92 | (cond ((nil? remain) 93 | (list (simplify-alist options-result) 94 | (reverse non-options-result))) 95 | ((not (_option? (car remain))) 96 | (loop (cdr remain) 97 | options-result 98 | (cons (car remain) non-options-result))) 99 | ((_long-option? (car remain)) 100 | (with option (_extract-long-option (car remain) options-spec) 101 | (if (_flag? option options-spec) 102 | (if (_option-arg? (car remain)) 103 | (err "Option takes no argument: --" option) 104 | (loop (cdr remain) 105 | (acons option #t options-result) 106 | non-options-result)) 107 | (aif (_option-arg? (car remain)) 108 | (loop (cdr remain) 109 | (acons option it options-result) 110 | non-options-result) 111 | (if (or (not (cons? (cdr remain))) 112 | (_option? (cadr remain))) 113 | (err "Option requires an argument: --" option) 114 | (loop (cddr remain) 115 | (acons option (cadr remain) options-result) 116 | non-options-result)))))) 117 | (#t ; short options 118 | (with option (_short->long (str-nth 1 (car remain)) 119 | options-spec) 120 | (if (_flag? option options-spec) 121 | (loop (cdr remain) 122 | (cat (map (lambda (c) 123 | (with option (_short->long c options-spec) 124 | (if (not (_flag? option options-spec)) 125 | (err "Option needs an argument: --" option) 126 | (list option #t)))) 127 | (drop 1 (unstr (car remain)))) 128 | options-result) 129 | non-options-result) 130 | (if (=? (str-len (car remain)) 2) 131 | (if (or (not (cons? (cdr remain))) 132 | (_option? (cadr remain))) 133 | (err "Option requires an argument: --" option) 134 | (loop (cddr remain) 135 | (acons option (cadr remain) options-result) 136 | non-options-result)) 137 | (loop (cdr remain) 138 | (acons option 139 | (str-drop (if (=? #chr "=" (str-nth 2 (car remain))) 3 2) 140 | (car remain)) 141 | options-result) 142 | non-options-result))))))) 143 | (loop args 144 | (map | option-spec (list (car option-spec) #f) 145 | options-spec) 146 | ()))) 147 | 148 | (defsub (parse-prog-args args options-spec) 149 | "Parse `args` according to `options-spec`; `non-options` is a str for the help output." 150 | (in-reg (_parse-prog-args args options-spec))) 151 | 152 | (defsub (say-prog-args-help name options-spec non-options-spec) 153 | "Display help output according to the given spec." 154 | (say "Usage: " name " [OPTIONS] " non-options-spec "\n\n") 155 | (each (lambda (option) 156 | (with short (assocar? 'short (cadr option)) 157 | (if short (say " -" (str (list short)) ", ")) 158 | (say (str* (if short 0 6) " ") 159 | "--" 160 | (str-padr 12 (str+ (sym->str (car option)) 161 | (if (assocar? 'flag (cadr option)) "" "=ARG"))) 162 | " " 163 | (aif (assocar? 'desc (cadr option)) it "") 164 | "\n"))) 165 | options-spec)) 166 | -------------------------------------------------------------------------------- /std/random.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/random.bn -- Standard random library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (defsub (random-choice choices) 17 | "Randomly choose an item; `choices` being of the form `((1 1/9-chance) (8 8/9-chance))`." 18 | (let ((total (apply + (map car choices))) 19 | (rnd (++ (sys.random total))) 20 | (loop (lambda (xs left) 21 | (with new-left (- left (caar xs)) 22 | (if (not (>0? new-left)) 23 | (cadar xs) 24 | (loop (cdr xs) new-left)))))) 25 | (loop choices rnd))) 26 | 27 | -------------------------------------------------------------------------------- /std/tap.bn: -------------------------------------------------------------------------------- 1 | ;;;; std/tap.bn -- Test Anything Protocol library. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | ;;;; This is a testing library that produces output which conforms to 17 | ;;;; the Test Anything Protocol (TAP), see www.testanything.org for 18 | ;;;; more information about TAP. This library does not support all 19 | ;;;; features of TAP yet, but the important thing is that its output 20 | ;;;; can be used by a test harness. 21 | 22 | (defvar *_test-number* 0) 23 | 24 | (mysub (_test-next) 25 | (_var! '*_test-number* (++ *_test-number*)) 26 | *_test-number*) 27 | 28 | (internsub (_test desc expr) 29 | (say (if expr "ok" "not ok") 30 | " " (_test-next) " " desc "\n")) 31 | 32 | (defmac (test desc . exprs) 33 | "Test whether all of `exprs` are true." 34 | `(_test ,desc (in-reg (and ,@(map (lambda (e) 35 | `(_protect (lambda () (eval ',e)))) 36 | exprs))))) 37 | 38 | (defmac (test-error desc . exprs) 39 | "Test whether all of `exprs` yield errors." 40 | `(_test ,desc (and ,@(map (lambda (e) 41 | `(not (_protect (lambda () (eval ',e) #t)))) 42 | exprs)))) 43 | 44 | (mysub (_count-tests) 45 | (with loop (lambda (so-far) 46 | (with expr (read) 47 | (cond ((eof? expr) so-far) 48 | ((member? (car? expr) '(test test-error)) (loop (++ so-far))) 49 | (#t (loop so-far))))) 50 | (loop 0))) 51 | 52 | (defsub (test-plan file) 53 | "Announce a test plan for `file`." 54 | (in-reg (with-file-src file 55 | (say "1.." (_count-tests) "\n")))) 56 | 57 | (defsub (test-plan-end) 58 | "Display the test plan at the end." 59 | (say "1.." *_test-number* "\n")) 60 | 61 | -------------------------------------------------------------------------------- /tests/base.bn: -------------------------------------------------------------------------------- 1 | ;;;; tests/base.bn -- Base language tests. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (use std/tap) 17 | 18 | (test-plan "tests/base.bn") 19 | 20 | (test "`(do)` doesn't change last_value." ; we expect that behaviour in `or` 21 | (eq? (do () (do)) ())) 22 | 23 | (test "nested `with`" 24 | (eq? 3 (with x 1 (with y 2 (+ x y)))) 25 | (eq? 2 (with x 1 (with x 2 x)))) 26 | 27 | (test "quasiquote" 28 | (eq? 3 ``,,(+ 1 2))) 29 | 30 | (test "equal?" 31 | (equal? '(1 a "foo") (list 1 'a "foo")) 32 | (equal? '(((1 . 2) 3 4 . 5) 6 (7 . (8 9))) 33 | '(((1 . 2) 3 4 . 5) 6 (7 8 9)))) 34 | 35 | (test "if" 36 | (if #t #t #f) 37 | (if #f #f #t) 38 | (not (if #f #t)) 39 | (if #f #f #f #t)) 40 | 41 | (test-error "invalid `if`" 42 | (if) 43 | (if #t)) 44 | 45 | (test "closures" 46 | ((lambda (a) (not a)) #f) 47 | (| x (nil? x) ()) 48 | (str=? "test" 49 | ((with x "test" 50 | (in-reg (lambda () x)))))) 51 | 52 | (test "eval" 53 | (eval #t) 54 | (eval '(eq? (+ 1 2) 3))) 55 | 56 | (test "copy" 57 | (equal? '(1 x (3) 4) (copy '(1 x (3) 4))) 58 | (str=? "test" (copy "test"))) 59 | 60 | (test "apply" 61 | (=? 10 (apply + (list 1 2 3 4))) 62 | (0? (apply - 10 1 '(2 3 4))) 63 | (0? (apply + ()))) 64 | 65 | (test "list*" 66 | (equal? (list* 1 2 3) '(1 2 . 3)) 67 | (eq? (list*) ())) 68 | 69 | (test "reverse" 70 | (equal? (reverse '(1 2 (3))) '((3) 2 1)) 71 | (eq? (reverse ()) ())) 72 | 73 | (test "member" 74 | (member? 'x '(a b c x y)) 75 | (not (member? 'x ()))) 76 | 77 | (test "`cat` with 2 args" 78 | (nil? (cat () ())) 79 | (equal? (cat '(1) ()) '(1)) 80 | (equal? (cat () '(2)) '(2))) 81 | 82 | (test "`cat` with 3 args" 83 | (nil? (cat () () ())) 84 | (equal? '(1 2) (cat '(1) () '(2)))) 85 | 86 | (test "len" 87 | (0? (len ())) 88 | (=? (len '(1 2)) 2)) 89 | 90 | (test "map" 91 | (equal? (map ++ '(0 1)) '(1 2)) 92 | (with x 10 93 | (equal? (map | n (+ x n) '(1 2)) 94 | '(11 12)))) 95 | 96 | (test "filter" 97 | (nil? (filter >0? '(0 -2))) 98 | (equal? (filter >0? '(1 -2 3 -5 6)) 99 | '(1 3 6)) 100 | (nil? (filter | x (err "oops") ()))) 101 | 102 | (test "sort" 103 | (equal? (sort ? 2147483648 2147483647) 112 | (>? 576460752303423487 576460752303423486) 113 | (=? 576460752303423487 (+ 576460752303423487 0)) 114 | (str" 122 | (str=? "0" (num->str 0)) 123 | (str=? "576460752303423487" (num->str 576460752303423487)) 124 | (str=? "-576460752303423488" (num->str -576460752303423488)) 125 | (str=? "0.1" (num->str 0.1)) 126 | (str=? "-999.99" (num->str -999.99))) 127 | 128 | (test "num?" 129 | (eq? #t (num? 123)) 130 | (eq? #t (num? 0.1)) 131 | (eq? #f (num? "str")) 132 | (eq? #f (num? ()))) 133 | 134 | (test "int?" 135 | (eq? #t (int? 123)) 136 | (eq? #f (int? 0.1)) 137 | (eq? #f (int? "str")) 138 | (eq? #f (int? ()))) 139 | 140 | (test "float?" 141 | (eq? #f (float? 123)) 142 | (eq? #t (float? 0.1)) 143 | (eq? #t (float? 1.0)) 144 | (eq? #f (float? "str")) 145 | (eq? #f (float? ()))) 146 | 147 | (test "+" 148 | (=? 0 (+)) 149 | (=? 4 (+ 4)) 150 | (=? 10 (+ 4 6)) 151 | (=? 10 (+ 1 2 3 4)) 152 | (=? 9.5 (+ 4 5.5)) 153 | (=? 9.5 (+ 1 2 3 3.5)) 154 | (=? 16.0 (+ 1 2.5 3 4.5 5)) 155 | (=? 576460752303423487 (+ 576460752303423485 1 1)) 156 | (int? (+ 5 4)) 157 | (int? (+ 1 2 3 4)) 158 | (float? (+ 5.5 4.5)) 159 | (float? (+ 1 2 3 3.5))) 160 | 161 | (test "-" 162 | (=? 4 (- 4)) 163 | (=? 6 (- 10 4)) 164 | (=? 4 (- 10 1 2 3)) 165 | (=? 4.5 (- 10 5.5)) 166 | (=? 3.5 (- 10 1 2 3.5)) 167 | (=? -6.0 (- 10 1 2.5 3 4.5 5)) 168 | (=? 576460752303423485 (- 576460752303423487 1 1))) 169 | 170 | (test "*" 171 | (=? 1 (*)) 172 | (=? 4 (* 4)) 173 | (=? 24 (* 4 6)) 174 | (=? 24 (* 1 2 3 4)) 175 | (=? 22.0 (* 4 5.5)) 176 | (=? 52.5 (* 3 5 3.5)) 177 | (=? 656.25 (* 3 5 3.5 5 2.5)) 178 | (=? 288230376151711744 (* 72057594037927936 2 2)) 179 | (int? (* 5 4)) 180 | (int? (* 1 2 3 4)) 181 | (float? (* 5.5 4.5)) 182 | (float? (* 1 2 3 3.5))) 183 | 184 | (test "/" 185 | (=? 4 (/ 20 5)) 186 | (=? 4.0 (/ 20 5.0)) 187 | (=? 4 (/ 21 5)) 188 | (=? 4.2 (/ 21 5.0)) 189 | (=? 5 (/ 30 2 3)) 190 | (=? 5.0 (/ 30 2.0 3)) 191 | (=? 5 (/ 31 2 3)) 192 | (=? 5.5 (/ 33 2.0 3)) 193 | (=? 72057594037927936 (/ 288230376151711744 2 2))) 194 | 195 | (test-error "`/` by zero" 196 | (/ 3 0) 197 | (/ 3 0.0) 198 | (/ 10 2 0 5) 199 | (/ 10 2 0.0 5)) 200 | 201 | (test "=?" 202 | (eq? #t (=? 1 1)) 203 | (eq? #t (=? 1 1.0)) 204 | (eq? #t (=? 1.5 1.5)) 205 | (eq? #t (=? 1 1 1 1)) 206 | (eq? #t (=? 1 1 1.0 1)) 207 | (eq? #f (=? 2 1)) 208 | (eq? #f (=? 2 1.0)) 209 | (eq? #f (=? 1 1 2 1)) 210 | (eq? #f (=? 1 1 2.0 1))) 211 | 212 | (test "<>?" 213 | (eq? #t (<>? 2 1)) 214 | (eq? #t (<>? 2 1.0))) 215 | (eq? #f (<>? 1 1)) 216 | (eq? #f (<>? 1 1.0)) 217 | (eq? #f (<>? 1.5 1.5)) 218 | 219 | (test ">?" 220 | (eq? #t (>? 2 1)) 221 | (eq? #t (>? -2 -3)) 222 | (eq? #t (>? 2 1.0)) 223 | (eq? #t (>? 1 0 -1)) 224 | (eq? #t (>? 4 3.0 2 1.0)) 225 | (eq? #f (>? 1 1)) 226 | (eq? #f (>? 1 2)) 227 | (eq? #f (>? 1 2.0)) 228 | (eq? #f (>? 4 3.0 2 2.5))) 229 | 230 | (test "=?" 242 | (eq? #t (>=? 1 1)) 243 | (eq? #t (>=? 2 1)) 244 | (eq? #t (>=? -2 -3)) 245 | (eq? #t (>=? 2 1.0)) 246 | (eq? #t (>=? 1 1 -1)) 247 | (eq? #t (>=? 4 3.0 2 1.0)) 248 | (eq? #f (>=? 1 2)) 249 | (eq? #f (>=? 1 2.0)) 250 | (eq? #f (>=? 4 3.0 2 2.5))) 251 | 252 | (test "<=?" 253 | (eq? #t (<=? 1 1)) 254 | (eq? #t (<=? 1 2)) 255 | (eq? #t (<=? -3 -2)) 256 | (eq? #t (<=? 1 2.0)) 257 | (eq? #t (<=? -1 1 1)) 258 | (eq? #t (<=? 1 2.0 3 4.0)) 259 | (eq? #f (<=? 2 1)) 260 | (eq? #f (<=? 2 1.0)) 261 | (eq? #f (<=? 1 2.0 3 2.5))) 262 | 263 | (test "UTF-8 I/O" 264 | (str=? "胨" (str '(33000))) 265 | (eq? #chr"ß" 223)) 266 | 267 | (test "case" 268 | (eq? #f (case 'y ((a b c) 'abc))) 269 | (eq? 'xyz (case 'y ((a b c) 'abc) ((x y z) 'xyz))) 270 | (eq? 'other (case 'e ((a b c) 'abc) ((x y z) 'xyz) (#t 'other)))) 271 | 272 | (test "assoc?" 273 | (eq? (car (assoc? 'e '((a b) (c d) (e f)))) 'f) 274 | (not (assoc? 'e '((a b) (c d))))) 275 | 276 | (test "assoc-entry?" 277 | (eq? (car (assoc-entry? 'e '((a b) (c d) (e f)))) 'e) 278 | (not (assoc-entry? 'e '((a b) (c d))))) 279 | 280 | (test "mod" 281 | (=? (mod 11 2) 1)) 282 | 283 | (test "bit operations" 284 | (=? (bit-and 6 3) 2) 285 | (=? (bit-and (bit-not 3) 7) 4) 286 | (=? (bit-or 3 4) 7) 287 | (=? (bit-xor 7 4) 3)) 288 | 289 | (test "str basics" 290 | (str? (str '(65))) 291 | (cons? (unstr "abc")) 292 | (nil? (unstr "")) 293 | (str=? "foo" "foo") 294 | (not (str=? "f" "foo")) 295 | (not (str=? "foo" "f")) 296 | (str<>? "f" "foo") 297 | (str<>? "foo" "f") 298 | (not (str<>? "foo" "foo")) 299 | (=? 1 (str-len "a")) 300 | (str-empty? "") 301 | (str-empty? (str+)) 302 | (str=? "foobar" (str+ "foo" "bar")) 303 | (str=? "foobar" (str+ "fo" "ob" "ar")) 304 | (str=? "foo" (str+ "foo")) 305 | (=? #chr "f" (str-nth 0 "foo"))) 306 | 307 | (test "sym interning" 308 | (str=? "abc" (sym->str (intern "abc")))) 309 | 310 | (test "acond" 311 | (=? -2 (acond ((str-pos? "ob" "foobar") (- 0 it)))) 312 | (0? (acond ((not #f) 0) ("abc" (str+ it "xyz")))) 313 | (str=? "abcxyz" (acond ((not #t) 0) ("abc" (str+ it "xyz")))) 314 | (not (acond (#f #t) (#f #t))) 315 | (not (acond))) 316 | 317 | (test "str-select" 318 | (str=? "de" (str-select 3 5 "abcdefghi"))) 319 | 320 | (test "str*" 321 | (str=? "foofoofoo" (str* 3 "foo")) 322 | (str-empty? (str* 0 "foo"))) 323 | 324 | (test "`str-pad` and str-padr" 325 | (str=? " foobar" (str-pad 7 "foobar")) 326 | (str=? "foobar" (str-pad 6 "foobar")) 327 | (str=? "foobar" (str-pad 3 "foobar")) 328 | (str=? "foobar " (str-padr 7 "foobar")) 329 | (str=? "foobar" (str-padr 6 "foobar")) 330 | (str=? "foobar" (str-padr 3 "foobar"))) 331 | 332 | (test "str-ascii-lower" 333 | (str=? (str-ascii-lower "FooBÄR_Q12.Png") 334 | "foobÄr_q12.png")) 335 | 336 | (test-error "`defsub` does not allow empty body or missing docstring" 337 | (defsub (foo) "oops") 338 | (defsub (bar) #t #t)) 339 | 340 | (test "round" 341 | (=? 3 (round 3.1)) 342 | (=? 3 (round 2.9)) 343 | (=? 3 (round 3)) 344 | (=? -3 (round -3.1)) 345 | (=? -3 (round -2.9)) 346 | (=? -3 (round -3)) 347 | (int? (round 3.1))) 348 | 349 | (test "ceil" 350 | (=? 4 (ceil 3.1)) 351 | (=? 3 (ceil 2.9)) 352 | (=? 3 (ceil 3)) 353 | (=? -3 (ceil -3.1)) 354 | (=? -2 (ceil -2.9)) 355 | (=? -3 (ceil -3)) 356 | (int? (ceil 3.1))) 357 | 358 | (test "floor" 359 | (=? 3 (floor 3.1)) 360 | (=? 2 (floor 2.9)) 361 | (=? 3 (floor 3)) 362 | (=? -4 (floor -3.1)) 363 | (=? -3 (floor -2.9)) 364 | (=? -3 (floor -3)) 365 | (int? (floor 3.1))) 366 | 367 | (test "trunc" 368 | (=? 3 (trunc 3.1)) 369 | (=? 2 (trunc 2.9)) 370 | (=? 3 (trunc 3)) 371 | (=? -3 (trunc -3.1)) 372 | (=? -2 (trunc -2.9)) 373 | (=? -3 (trunc -3)) 374 | (int? (trunc 3.1))) 375 | 376 | (test "int->float" 377 | (=? 3 (int->float 3)) 378 | (float? (int->float 3))) 379 | 380 | ;;; Most of the (un)folding tests are adapted from the examples in SRFI-1. 381 | 382 | (test "fold" 383 | (=? 6 (fold + 0 '(1 2 3))) 384 | (equal? '(3 2 1) (fold cons () '(1 2 3))) 385 | (=? 2 (fold | x count (if (sym? x) (++ count) count) 386 | 0 387 | '(1 2 a 4 5 b 7))) 388 | (=? 4 (fold (lambda (s max-len) 389 | (if (>? max-len (str-len s)) 390 | max-len 391 | (str-len s))) 392 | 0 393 | '("ab" "c" "defg" "hi")))) 394 | 395 | (test "foldr" 396 | (equal? '(1 2 3) (foldr cons '() '(1 2 3))) 397 | (equal? '(a b) (foldr (lambda (x l) 398 | (if (sym? x) 399 | (cons x l) 400 | l)) 401 | () 402 | '(1 2 a 4 5 b 7)))) 403 | 404 | (test "unfold" 405 | (equal? '(1 4 9 16 25 36 49 64 81 100) 406 | (unfold | x (>? x 10) 407 | | x (* x x) 408 | ++ 409 | 1)) 410 | (equal? '(1 2 a 4 5 b 7) 411 | (unfold nil? car cdr '(1 2 a 4 5 b 7)))) 412 | 413 | (test "unfoldr" 414 | (equal? '(1 4 9 16 25 36 49 64 81 100) 415 | (unfold-right 0? | x (* x x) -- 10)) 416 | (equal? '(3 2 1) (unfold-right nil? car cdr '(1 2 3)))) 417 | 418 | (test "flatten" 419 | (equal? '(1 2 3 4 5) 420 | (flatten '(1 (2) ((3 (4)) 5))))) 421 | 422 | (test "find?" 423 | (not (find? sym? '(1 2 3))) 424 | (=? -3 (find? (partial >? 0) '(0 1 -3 -4))) 425 | (not (find? id ()))) 426 | 427 | (test "any?" 428 | (any? sym? '(1 2 3 a 5)) 429 | (any? sym? '(a b c)) 430 | (not (any? sym? '(1 2 3))) 431 | (not (any? sym? ()))) 432 | 433 | (test "all?" 434 | (not (all? sym? '(a b 3 d))) 435 | (all? sym? '(a b c)) 436 | (all? (compose not sym?) '(1 2 3)) 437 | (all? sym? ())) 438 | 439 | (test "drop" 440 | (equal? '(3) (drop 2 '(1 2 3))) 441 | (nil? (drop 3 '(1 2 3))) 442 | (nil? (drop 5 '(1 2 3))) 443 | (equal? '(1 2 3) (drop 0 '(1 2 3)))) 444 | 445 | (test "dropr" 446 | (equal? '(1) (dropr 2 '(1 2 3))) 447 | (nil? (dropr 3 '(1 2 3))) 448 | (nil? (dropr 5 '(1 2 3))) 449 | (equal? '(1 2 3) (dropr 0 '(1 2 3)))) 450 | 451 | (test "take" 452 | (equal? '(1 2) (take 2 '(1 2 3))) 453 | (equal? '(1 2 3) (take 3 '(1 2 3))) 454 | (equal? '(1 2 3) (take 5 '(1 2 3))) 455 | (nil? (take 0 '(1 2 3)))) 456 | 457 | (test "taker" 458 | (equal? '(2 3) (taker 2 '(1 2 3))) 459 | (equal? '(1 2 3) (taker 3 '(1 2 3))) 460 | (equal? '(1 2 3) (taker 5 '(1 2 3))) 461 | (nil? (taker 0 '(1 2 3)))) 462 | 463 | (test "rlambda" 464 | (=? 7 ((rlambda re (xs) 465 | (if (nil? xs) 466 | 0 467 | (++ (re (cdr xs))))) 468 | '(1 2 3 4 a b c)))) 469 | 470 | (test "aif" 471 | (eq? 2 (aif 2 it #f)) 472 | (aif #f #f #t) 473 | (not (aif #f #t)) 474 | (eq? 2 (aif #f #f #f 2)) 475 | (not (aif #f #t it))) 476 | 477 | (test "str-subst" 478 | (str=? "fobar" (str-subst "o" "" "foobar")) 479 | (str=? "fo<>ar" (str-subst "ob" "<>" "foobar")) 480 | (str=? "foiiiar" (str-subst "ob" "iii" "foobar")) 481 | (str=? "foxar" (str-subst "ob" "x" "foobar"))) 482 | 483 | (test "str-gsubst" 484 | (str=? "f**bar" (str-gsubst "o" "*" "foobar")) 485 | (str=? "f-bar" (str-gsubst "oo" "-" "foobar")) 486 | (str=? "&" (str-gsubst "&" "&" "&")) 487 | (str=? "yes & no & void" (str-gsubst "&" "&" "yes & no & void"))) 488 | -------------------------------------------------------------------------------- /tests/bench.bn: -------------------------------------------------------------------------------- 1 | ;;;; tests/bench.bn -- std/bench library tests. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Dov Murik 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (use std/tap) 17 | (use std/bench) 18 | 19 | (test-plan "tests/bench.bn") 20 | 21 | (test "`measure-time`" 22 | (") 23 | "<a href="foo">")) 24 | -------------------------------------------------------------------------------- /tests/math.bn: -------------------------------------------------------------------------------- 1 | ;;;; tests/math.bn -- Base language tests. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Wolfgang Jaehrling 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (use std/tap) 17 | (use std/math) 18 | 19 | (test-plan "tests/math.bn") 20 | 21 | (test "creating a large list" 22 | (iota* 1 10000 1)) 23 | -------------------------------------------------------------------------------- /tests/posix.bn: -------------------------------------------------------------------------------- 1 | ;;;; tests/posix.bn -- POSIX operations tests. -*- bone -*- 2 | ;;;; Copyright (C) 2016 Dov Murik 3 | ;;;; 4 | ;;;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;;;; purpose with or without fee is hereby granted, provided that the above 6 | ;;;; copyright notice and this permission notice appear in all copies. 7 | ;;;; 8 | ;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | 16 | (use std/tap) 17 | 18 | (test-plan "tests/posix.bn") 19 | 20 | (test "`gettimeofday`" 21 | (let ((t (gettimeofday)) 22 | (sec (car t)) 23 | (usec (cadr t))) 24 | (and (<=? 0 usec 999999) 25 | (