├── LICENSE ├── README.md ├── boot.lisp ├── contrib ├── parser-combinators-stream.lisp ├── parser-combinators.lisp ├── stream.lisp └── tbl.lisp ├── examples ├── backtrack.lisp ├── conways-gol.lisp ├── fizzbuzz.lisp ├── hello.lisp └── quine.lisp ├── gentest ├── test └── testsuites ├── compiler ├── parser └── vm /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright yubrot (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of yubrot nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Rosetta Lisp 2 | 3 | Rosetta Lisp is a set of Lisp-1 implementations that share the VM instruction 4 | set, built-in functions, and the bootstrapping code. 5 | 6 | - [Introduction article (Japanese)](https://zenn.dev/yubrot/articles/0ea5405ea53de5) 7 | 8 | ## Implementations 9 | 10 | Currently there are 6 implementations available. Each of them is implemented in 11 | different languages. 12 | 13 | - [ocalisp](https://github.com/yubrot/ocalisp) in [OCaml](https://ocaml.org/) (Reference implementation) 14 | - [scalisp](https://github.com/yubrot/scalisp) in [Scala 3](https://www.scala-lang.org/) 15 | - [golisp](https://github.com/yubrot/golisp) in [Go](https://go.dev/) 16 | - [fslisp](https://github.com/yubrot/fslisp) in [F#](https://fsharp.org/) 17 | - [kokalisp](https://github.com/yubrot/kokalisp) in [Koka 3](https://koka-lang.github.io/) 18 | - [idrlisp](https://github.com/yubrot/idrlisp) in [Idris 1](https://www.idris-lang.org/) (Out of date) 19 | - [wonderlisp](https://github.com/yubrot/wonderlisp) in Rosetta Lisp itself 20 | 21 | ## VM Design 22 | 23 | The design of the Rosetta Lisp implementation is heavily inspired by 24 | [SECD machine](https://en.wikipedia.org/wiki/SECD_machine). Every S-expression 25 | is macro-expanded and then compiled into a code, a sequence of instructions. 26 | Rosetta Lisp implementations share an extremely simple, small instruction set 27 | that targeting an SECD-like virtual machine. 28 | 29 | ### VM Instruction Set 30 | 31 | Rosetta Lisp VM consists of four states: 32 | 33 | - `[S]tack` - a list of values 34 | - `[E]nvironment` - an abstract representation of a collection of key-value 35 | pairs 36 | - `[C]ode` - a list of instructions 37 | - `[D]ump` - a list of pairs of Environment and Code 38 | 39 | #### ldc value 40 | 41 | Push a `value` on top of `S`. 42 | 43 | ```lisp 44 | (define (ldc value) 45 | (lambda (S E C D k) 46 | (k (cons value S) E C D))) 47 | ``` 48 | 49 | #### ldv name 50 | 51 | Find a binding for `name` from `E` and push the value on top of `S`. 52 | 53 | ```lisp 54 | (define (ldv name) 55 | (lambda (S E C D k) 56 | (k (cons (find-env name E) S) E C D))) 57 | ``` 58 | 59 | #### ldf pattern code 60 | 61 | Make a function capturing `E` and push it on top of `S`. 62 | 63 | ```lisp 64 | (define (ldf pattern code) 65 | (lambda (S E C D k) 66 | (k (cons (make-function-closure pattern code E) S) E C D))) 67 | ``` 68 | 69 | #### ldm pattern code 70 | 71 | Make a macro capturing `E` and push it on top of `S`. 72 | 73 | ```lisp 74 | (define (ldm pattern code) 75 | (lambda (S E C D k) 76 | (k (cons (make-macro-closure pattern code E) S) E C D))) 77 | ``` 78 | 79 | #### ldb name 80 | 81 | Find a built-in function named `name` and push it on top of `S`. 82 | 83 | ```lisp 84 | (define (ldb name) 85 | (lambda (S E C D k) 86 | (k (cons (find-builtin-function name) S) E C D))) 87 | ``` 88 | 89 | #### sel then-code else-code 90 | 91 | Pop a value from `S`, set `C` to `then-code` if the value is `#f`, set `C` to 92 | `else-code` otherwise. Set `E` to a new environment derived from `E`. Push the 93 | previous `E` and `C` on top of `D`. 94 | 95 | ```lisp 96 | (define (sel then-code else-code) 97 | (lambda ((s . S) E C D k) 98 | (k S 99 | (new-env E) 100 | (if s then-code else-code) 101 | (cons (cons E C) D)))) 102 | ``` 103 | 104 | #### leave 105 | 106 | Pop a pair of Environment and Code from `D` and set `E` and `C` to it. 107 | 108 | ```lisp 109 | (define (leave) 110 | (lambda (S E C ((e . c) . D) k) 111 | (k S e c D))) 112 | ``` 113 | 114 | #### app argc 115 | 116 | Pop `argc` values as function arguments from `S`, pop a function from `S`, call 117 | the function with the arguments. 118 | 119 | ```lisp 120 | (define (app argc) 121 | (lambda ((argN argN-1 ... arg1 f . S) E C D k) 122 | (apply-function f (list arg1 .. argN) S E C D k))) 123 | ``` 124 | 125 | `apply-function` is defined for built-in functions and function closures 126 | obtained by `ldf`. `apply-function` on function closures is defined as follows: 127 | 128 | ```lisp 129 | (define (apply-function (FUNCTION-CLOSURE pattern code env) 130 | args 131 | S E C D k) 132 | (k S 133 | (bind-args-with-pattern args pattern (new-env env)) 134 | code 135 | (cons (cons E C) D))) 136 | ``` 137 | 138 | #### pop 139 | 140 | Pop a value from `S`. 141 | 142 | ```lisp 143 | (define (pop) 144 | (lambda ((s . S) E C D k) 145 | (k S E C D))) 146 | ``` 147 | 148 | #### def name 149 | 150 | Pop a value, create a binding from `name` to the value on `E`. 151 | 152 | ```lisp 153 | (define (def name) 154 | (lambda ((s . S) E C D k) 155 | (k S (env-define name s E) C D))) 156 | ``` 157 | 158 | #### set name 159 | 160 | Pop a value, update a binding from `name` to the value on `E`. 161 | 162 | ```lisp 163 | (define (set name) 164 | (lambda ((s . S) E C D k) 165 | (k S (env-set name s E) C D))) 166 | ``` 167 | 168 | ### Compilation to VM instructions 169 | 170 | All literals and quoted expressions are compiled into `ldc`: 171 | 172 | ``` 173 | ; compiling 123 174 | [0 entry] 175 | ldc 123 176 | ``` 177 | 178 | All unquoted symbols are compiled into `ldv`: 179 | 180 | ``` 181 | ; compiling foo 182 | [0 entry] 183 | ldv foo 184 | ``` 185 | 186 | Lists are compiled into a sequence of element evaluations and an `app`. 187 | 188 | ``` 189 | ; compiling (compare a b) 190 | [0 entry] 191 | ldv compare 192 | ldv a 193 | ldv b 194 | app 2 195 | 196 | ; compiling (+ foo (* bar baz) 111) 197 | [0 entry] 198 | ldv + 199 | ldv foo 200 | ldv * 201 | ldv bar 202 | ldv baz 203 | app 2 204 | ldc 111 205 | app 3 206 | ``` 207 | 208 | All other instructions are produced by **Syntax**. Applications of Syntax are 209 | not compiled into an usual `app`. 210 | 211 | `(builtin cons)` produces a `ldb`. 212 | 213 | ``` 214 | [0 entry] 215 | ldb hello 216 | ``` 217 | 218 | `(if a b c)` produces a `sel` and two branch codes terminated by a `leave`. 219 | 220 | ``` 221 | [0 entry] 222 | ldv a 223 | sel [1 then] [2 else] 224 | [1 then] 225 | ldv b 226 | leave 227 | [2 else] 228 | ldv c 229 | leave 230 | ``` 231 | 232 | `(begin a b c)` produces a sequence of evaluations and `pop`s. 233 | 234 | ``` 235 | [0 entry] 236 | ldv a 237 | pop 238 | ldv b 239 | pop 240 | ldv c 241 | ``` 242 | 243 | `(fun (x y) y)` produces a `ldf`, `(macro (x y) x)` produces a `ldm`. Body of 244 | functions are terminated by a `leave` but macros are not. 245 | 246 | ``` 247 | [0 entry] 248 | ldf [1 fun (x y)] 249 | [1 fun (x y)] 250 | ldv y 251 | leave 252 | ``` 253 | 254 | ``` 255 | [0 entry] 256 | ldm [1 macro (x y)] 257 | [1 macro (x y)] 258 | ldv x 259 | ``` 260 | 261 | `(def x 123)` produces a `def`, `(set! x 123)` produces a `set`. Both of them 262 | also produce a `ldc ()` to adjust stack size. 263 | 264 | ``` 265 | [0 entry] 266 | ldc 123 267 | def x 268 | ldc () 269 | ``` 270 | 271 | ``` 272 | [0 entry] 273 | ldc 123 274 | set x 275 | ldc () 276 | ``` 277 | 278 | `(quote x)` is also one of Syntax that produces a `ldc`. 279 | 280 | ## Built-in functions 281 | 282 | All other functionalities are injected as built-in functions. Every 283 | implementation provides the same built-in function set. By doing this, Every 284 | implementation can use [the same bootstrapping code](./boot.lisp) to get 285 | frequently used functions and macros. 286 | 287 | ### Built-in functions required by the bootstrapping code 288 | 289 | To reduce the size of required built-in functions, there are a lot of functions 290 | and macros that are defined in the bootstrapping code instead of in host 291 | languages. It's not optimal in terms of performance, but it makes easy to add 292 | another Rosetta Lisp implementation. 293 | 294 | In the following documentation, `result` means a result cons cell. 295 | 296 | - If `car` is `#t`, the result `a` is set to `cdr`. 297 | - If `car` is `#f`, the failure error information `str` is set to `cdr`. 298 | 299 | #### Cons cell operators 300 | 301 | | name | overloads | 302 | | ------ | ---------------- | 303 | | `cons` | `(_, _) -> cons` | 304 | | `car` | `(cons) -> _` | 305 | | `cdr` | `(cons) -> _` | 306 | 307 | #### Terminators 308 | 309 | | name | overloads | 310 | | ------- | ------------- | 311 | | `exit` | `(?num) -> !` | 312 | | `error` | `(?str) -> !` | 313 | 314 | #### Macro supports 315 | 316 | NOTE: `quote` is a syntax, `quasiquote` and `unquote` are implemented on 317 | `boot.lisp`. 318 | 319 | | name | overloads | note | 320 | | -------- | ----------- | ------------------------------------- | 321 | | `gensym` | `() -> sym` | Must not overlap with symbol literals | 322 | 323 | #### Control operators 324 | 325 | | name | overloads | 326 | | --------- | ------------------- | 327 | | `apply` | `(proc, list) -> _` | 328 | | `call/cc` | `(proc) -> _` | 329 | | `never` | `(proc, ..._) -> !` | 330 | 331 | #### Test operators 332 | 333 | | name | overloads | note | 334 | | ------- | ------------- | ------------------------------------- | 335 | | `num?` | `(_) -> bool` | | 336 | | `sym?` | `(_) -> bool` | | 337 | | `str?` | `(_) -> bool` | | 338 | | `cons?` | `(_) -> bool` | | 339 | | `nil?` | `(_) -> bool` | | 340 | | `bool?` | `(_) -> bool` | | 341 | | `proc?` | `(_) -> bool` | Built-in functions and user functions | 342 | | `meta?` | `(_) -> bool` | Language syntax and user macros | 343 | | `vec?` | `(_) -> bool` | | 344 | 345 | #### Arithmetic operators 346 | 347 | | name | overloads | 348 | | ---- | ---------------------- | 349 | | `+` | `(...num) -> num` | 350 | | `-` | `(num, ...num) -> num` | 351 | | `*` | `(...num) -> num` | 352 | | `/` | `(num, ...num) -> num` | 353 | | `%` | `(num, ...num) -> num` | 354 | 355 | #### Relational operators 356 | 357 | | name | overloads | 358 | | ---- | -------------------------------------- | 359 | | `=` | `(..._) -> bool` | 360 | | `<` | `(...num) -> bool`, `(...str) -> bool` | 361 | | `>` | `(...num) -> bool`, `(...str) -> bool` | 362 | | `<=` | `(...num) -> bool`, `(...str) -> bool` | 363 | | `>=` | `(...num) -> bool`, `(...str) -> bool` | 364 | 365 | #### `str` operators 366 | 367 | String encoding is not specified, but is expected to be ASCII compatible through 368 | these operators. This requirement is usually satisfied by using a Unicode scalar 369 | sequence or byte sequence. 370 | 371 | | name | overloads | note | 372 | | ------------- | ----------------------------- | ---------------------------------------------------------------------------- | 373 | | `str` | `(...num) -> str \| !` | Each `num` corresponds to a character. Raises an error on invalid characters | 374 | | `str-char-at` | `(str, num) -> num \| nil` | Takes an index. Returns a character | 375 | | `str-length` | `(str) -> num` | Returns character count | 376 | | `str-concat` | `(...str) -> str` | | 377 | | `substr` | `(str, num, num) -> str \| !` | Takes a str, index, and length. Raises an error on out of range | 378 | | `sym->str` | `(sym) -> str` | | 379 | | `num->str` | `(num) -> str` | | 380 | | `str->num` | `(str) -> num \| nil` | | 381 | 382 | #### `vec` operators 383 | 384 | `vec` is a type for minimal support of mutable/fixed-length sequential data. 385 | 386 | | name | overloads | note | 387 | | ------------ | --------------------------------------- | ---------------------------------------------------------------- | 388 | | `vec` | `(..._) -> vec` | | 389 | | `vec-make` | `(num, _) -> vec` | Takes a length and initial value | 390 | | `vec-length` | `(vec) -> num` | | 391 | | `vec-get` | `(vec, num) -> _ \| nil` | Get by index | 392 | | `vec-set!` | `(vec, num, _) -> nil \| !` | Set by index. Raises an error on out of range | 393 | | `vec-copy!` | `(vec, num, vec, num, num) -> nil \| !` | Takes a dest, dest-start-index, src, src-start-index, and length | 394 | 395 | #### I/O operators 396 | 397 | | name | overloads | note | 398 | | ------------------- | --------------------------- | ----------------------------------------------- | 399 | | `read-file-text` | `(str) -> result` | Takes a file path. Returns contents of the file | 400 | | `write-file-text` | `(str, str) -> result` | Takes a file path and contents | 401 | | `read-console-line` | `() -> result` | No line feed at end. Returns nil if terminated | 402 | | `write-console` | `(str) -> result` | | 403 | 404 | #### Misc 405 | 406 | | name | overloads | note | 407 | | --------------- | ------------------ | --------------------------------------------- | 408 | | `args` | `() -> list` | Returns command line arguments as list of str | 409 | | `eval` | `(_) -> result<_>` | Evaluates a S-expression | 410 | | `macroexpand` | `(_) -> result<_>` | Perform macro expansion | 411 | | `macroexpand-1` | `(_) -> result<_>` | Perform one step macro expansion | 412 | 413 | ## Tests 414 | 415 | There are [test suites](./testsuites) for the functionalities of the parser, the 416 | compiler, and the VM. Rosetta Lisp's bootstrapping code includes unit tests for 417 | each built-in function, as comments. 418 | 419 | ```lisp 420 | (def cons (builtin cons)) 421 | ;! > (cons 1) 422 | ;! fail 423 | ;! > (cons 1 2) 424 | ;! (1 . 2) 425 | ;! > (cons 1 2 3) 426 | ;! fail 427 | ``` 428 | 429 | Since it's troublesome to parse these comments, there is 430 | [a unified, easy-to-parse test file](./test) available. This test file is 431 | generated by [./gentest](./gentest). 432 | -------------------------------------------------------------------------------- /boot.lisp: -------------------------------------------------------------------------------- 1 | (def cons (builtin cons)) 2 | ;! > (cons 1) 3 | ;! fail 4 | ;! > (cons 1 2) 5 | ;! (1 . 2) 6 | ;! > (cons 1 2 3) 7 | ;! fail 8 | 9 | (def list (fun xs xs)) 10 | 11 | (def defun (macro (sym . body) (list 'def sym (cons 'fun body)))) 12 | (def defmacro (macro (sym . body) (list 'def sym (cons 'macro body)))) 13 | (def defbuiltin (macro (sym . intf) (list 'def sym (list 'builtin sym)))) 14 | ;! > (defun _f (a b) b) 15 | ;! () 16 | ;! > (_f 3 5) 17 | ;! 5 18 | ;! > (defmacro _m (a . b) b) 19 | ;! () 20 | ;! > (_m 1 _f 2 3) 21 | ;! 3 22 | 23 | (defbuiltin exit (exitcode)) 24 | (defbuiltin error (msg)) 25 | 26 | (defbuiltin gensym ()) 27 | 28 | (defbuiltin car (cons)) 29 | (defbuiltin cdr (cons)) 30 | ;! > (car (cons 12 34)) 31 | ;! 12 32 | ;! > (cdr (cons 12 34)) 33 | ;! 34 34 | 35 | (defbuiltin apply (f args)) 36 | ;! > (apply cons (list 12 34)) 37 | ;! (12 . 34) 38 | 39 | (defun id (a) 40 | a) 41 | ;! > (id 0) 42 | ;! 0 43 | ;! > (id "foo") 44 | ;! "foo" 45 | 46 | (defun compose (f g) 47 | (fun (x) (f (g x)))) 48 | ;! > ((compose car cdr) (list 12 34 56)) 49 | ;! 34 50 | 51 | (defun flip (f) 52 | (fun (a b) (f b a))) 53 | ;! > ((flip (fun (a b) a)) 12 34) 54 | ;! 34 55 | 56 | (defun const (v) 57 | (fun _ v)) 58 | ;! > ((const 123)) 59 | ;! 123 60 | ;! > ((const 123) 456 789) 61 | ;! 123 62 | 63 | (def caar (compose car car)) 64 | (def cadr (compose car cdr)) 65 | (def cdar (compose cdr car)) 66 | (def cddr (compose cdr cdr)) 67 | (def caaar (compose car caar)) 68 | (def cdaar (compose cdr caar)) 69 | (def cadar (compose car cdar)) 70 | (def cddar (compose cdr cdar)) 71 | (def caadr (compose car cadr)) 72 | (def cdadr (compose cdr cadr)) 73 | (def caddr (compose car cddr)) 74 | (def cdddr (compose cdr cddr)) 75 | 76 | (defbuiltin num? (x)) 77 | (defbuiltin sym? (x)) 78 | (defbuiltin str? (x)) 79 | (defbuiltin cons? (x)) 80 | (defbuiltin nil? (x)) 81 | (defbuiltin bool? (x)) 82 | (defbuiltin proc? (x)) 83 | (defbuiltin meta? (x)) 84 | (defbuiltin vec? (x)) 85 | ;! > (num? 123) 86 | ;! #t 87 | ;! > (num? 12 34) 88 | ;! fail 89 | ;! > (num? "foo") 90 | ;! #f 91 | ;! > (sym? 'foo) 92 | ;! #t 93 | ;! > (str? "foo") 94 | ;! #t 95 | ;! > (cons? (list 1 2 3)) 96 | ;! #t 97 | ;! > (nil? ()) 98 | ;! #t 99 | ;! > (list (bool? #t) (bool? ())) 100 | ;! (#t #f) 101 | ;! > (list (proc? (fun ())) (proc? cons) (proc? (macro ())) (proc? def)) 102 | ;! (#t #t #f #f) 103 | ;! > (list (meta? (fun ())) (meta? cons) (meta? (macro ())) (meta? def)) 104 | ;! (#f #f #t #t) 105 | ;! > (list (vec? 123)) 106 | ;! (#f) 107 | 108 | (defun list? (x) 109 | (if (nil? x) 110 | #t 111 | (if (cons? x) 112 | (list? (cdr x)) 113 | #f))) 114 | ;! > (list? ()) 115 | ;! #t 116 | ;! > (list? '(12 . 34)) 117 | ;! #f 118 | ;! > (list? '(12 34 . 56)) 119 | ;! #f 120 | ;! > (list? '(12 34 56)) 121 | ;! #t 122 | 123 | (defbuiltin + nums) 124 | (defbuiltin - (num . nums)) 125 | (defbuiltin * nums) 126 | (defbuiltin / (num . nums)) 127 | (defbuiltin % (num . nums)) 128 | ;! > (list (+) (+ 11) (+ 3 4 5)) 129 | ;! (0 11 12) 130 | ;! > (list (- 5) (- 5 2)) 131 | ;! (-5 3) 132 | ;! > (list (*) (* 11) (* 3 4 5)) 133 | ;! (1 11 60) 134 | ;! > (list (/ 2) (/ 20 5 2)) 135 | ;! (0.5 2) 136 | ;! > (list (% 5) (% 5 3)) 137 | ;! (5 2) 138 | 139 | (defbuiltin = xs) 140 | ;! > (list (=) (= 1) (= 1 1) (= 1 2) (= 1 1 1) (= 1 1 2)) 141 | ;! (#t #t #t #f #t #f) 142 | ;! > (list (= "foo" "foo") (= "foo" "bar")) 143 | ;! (#t #f) 144 | ;! > (list (= #t #t) (= #f #f) (= #t #f)) 145 | ;! (#t #t #f) 146 | ;! > (list (= () ()) (= '(1 2) '(1 2)) (= '(1 2) '(1 3)) (= '(1 2 . 3) '(1 2 . 3)) (= '(1 2 3) '(1 2 . 3))) 147 | ;! (#t #t #f #t #f) 148 | ;! > (= (fun ()) (fun ())) 149 | ;! #f 150 | ;! > (list (= 123 "123") (= "foo" 'foo)) 151 | ;! (#f #f) 152 | 153 | (defbuiltin < nums-or-strs) 154 | (defbuiltin > nums-or-strs) 155 | (defbuiltin <= nums-or-strs) 156 | (defbuiltin >= nums-or-strs) 157 | ;! > (list (<) (< 1) (< 1 2) (< 1 2 3) (< 1 3 3) (< 1 4 3) (< 4 3) (< 4 4 3)) 158 | ;! (#t #t #t #t #f #f #f #f) 159 | ;! > (list (>) (> 1) (> 1 2) (> 1 2 3) (> 1 3 3) (> 1 4 3) (> 4 3) (> 4 4 3)) 160 | ;! (#t #t #f #f #f #f #t #f) 161 | ;! > (list (<=) (<= 1) (<= 1 2) (<= 1 2 3) (<= 1 3 3) (<= 1 4 3) (<= 4 3) (<= 4 4 3)) 162 | ;! (#t #t #t #t #t #f #f #f) 163 | ;! > (list (>=) (>= 1) (>= 1 2) (>= 1 2 3) (>= 1 3 3) (>= 1 4 3) (>= 4 3) (>= 4 4 3)) 164 | ;! (#t #t #f #f #f #f #t #t) 165 | ;! > (list (< "abc" "cab") (< "abc" "abd") (< "bac" "acb")) 166 | ;! (#t #t #f) 167 | ;! > (< 123 "456") 168 | ;! fail 169 | ;! > (< #f) 170 | ;! fail 171 | 172 | (defun map (f xs) 173 | (if (nil? xs) 174 | () 175 | (cons (f (car xs)) (map f (cdr xs))))) 176 | ;! > (map (fun (a) (* a 3)) (list 1 2 5 4)) 177 | ;! (3 6 15 12) 178 | 179 | (defun filter (f xs) 180 | (if (nil? xs) 181 | () 182 | (if (f (car xs)) 183 | (cons (car xs) (filter f (cdr xs))) 184 | (filter f (cdr xs))))) 185 | ;! > (filter num? (list 1 2 "foo" 3 'bar 4)) 186 | ;! (1 2 3 4) 187 | 188 | (def for (flip map)) 189 | ;! > (for (list 1 2 3) (fun (a) (* a a))) 190 | ;! (1 4 9) 191 | 192 | (defun foldl (f i xs) 193 | (if (nil? xs) 194 | i 195 | (foldl f (f i (car xs)) (cdr xs)))) 196 | ;! > (foldl cons () (list 2 5 3)) 197 | ;! (((() . 2) . 5) . 3) 198 | 199 | (defun foldr (f i xs) 200 | (if (nil? xs) 201 | i 202 | (f (car xs) (foldr f i (cdr xs))))) 203 | ;! > (foldr cons () (list 2 5 3)) 204 | ;! (2 5 3) 205 | 206 | (defun append ls 207 | (foldr *append () ls)) 208 | 209 | (defun *append (a b) 210 | (if (nil? a) 211 | b 212 | (cons (car a) (*append (cdr a) b)))) 213 | ;! > (append (list 1 2 3) (list 4 5 6) (list 7 8)) 214 | ;! (1 2 3 4 5 6 7 8) 215 | 216 | (defun reverse (ls) 217 | (foldl (flip cons) () ls)) 218 | ;! > (reverse (list 1 2 4 5)) 219 | ;! (5 4 2 1) 220 | 221 | (defun nth (n xs) 222 | (if (= n 0) 223 | (car xs) 224 | (nth (- n 1) (cdr xs)))) 225 | ;! > (nth 3 (list 9 8 7 6 5)) 226 | ;! 6 227 | 228 | (defun iota (a b) 229 | (if (< a b) 230 | (cons a (iota (+ a 1) b)) 231 | '())) 232 | ;! > (iota 0 5) 233 | ;! (0 1 2 3 4) 234 | ;! > (iota 2 4) 235 | ;! (2 3) 236 | ;! > (iota 3 3) 237 | ;! () 238 | 239 | (defun not (x) 240 | (if x #f #t)) 241 | ;! > (map not (list 123 () #t #f)) 242 | ;! (#f #f #f #t) 243 | 244 | (def else #t) 245 | 246 | (defmacro cond preds 247 | (if (nil? preds) 248 | () 249 | (list 'if (caar preds) 250 | (cons 'begin (cdar preds)) 251 | (cons 'cond (cdr preds))))) 252 | ;! > (cond) 253 | ;! () 254 | ;! > (cond [#t 123]) 255 | ;! 123 256 | ;! > (cond [#t 123 456]) 257 | ;! 456 258 | ;! > (cond [#t 1] [#t 2] [#t 3]) 259 | ;! 1 260 | ;! > (cond [#f 1] [#t 2] [#t 3]) 261 | ;! 2 262 | ;! > (cond [#f 1] [#f 2] [#t 3]) 263 | ;! 3 264 | ;! > (cond [#f 1] [#f 2] [#f 3]) 265 | ;! () 266 | ;! > (def _r ()) 267 | ;! () 268 | ;! > (cond 269 | ;! > [(begin (set! _r (cons 1 _r)) #f) (set! _r (cons 2 _r))] 270 | ;! > [(begin (set! _r (cons 3 _r)) #t) (set! _r (cons 4 _r))] 271 | ;! > [(begin (set! _r (cons 5 _r)) #t) (set! _r (cons 6 _r))]) 272 | ;! () 273 | ;! > _r 274 | ;! (4 3 1) 275 | 276 | (defmacro and values 277 | (cond 278 | [(nil? values) #t] 279 | [(nil? (cdr values)) (car values)] 280 | [else ((fun (tmp) 281 | (list (list 'fun (list tmp) 282 | (list 'if tmp (cons 'and (cdr values)) tmp)) 283 | (car values))) 284 | (gensym))])) 285 | ;! > (and) 286 | ;! #t 287 | ;! > (and 123) 288 | ;! 123 289 | ;! > (and 123 456) 290 | ;! 456 291 | ;! > (and #f 456) 292 | ;! #f 293 | ;! > (and 123 456 789) 294 | ;! 789 295 | ;! > (def _r ()) 296 | ;! () 297 | ;! > (and 298 | ;! > (begin (set! _r (cons 1 _r)) 123) 299 | ;! > (begin (set! _r (cons 2 _r)) 456) 300 | ;! > (begin (set! _r (cons 3 _r)) #f) 301 | ;! > (begin (set! _r (cons 4 _r)) 789)) 302 | ;! #f 303 | ;! > _r 304 | ;! (3 2 1) 305 | 306 | (defmacro or values 307 | (cond 308 | [(nil? values) #f] 309 | [(nil? (cdr values)) (car values)] 310 | [else ((fun (tmp) 311 | (list (list 'fun (list tmp) 312 | (list 'if tmp tmp (cons 'or (cdr values)))) 313 | (car values))) 314 | (gensym))])) 315 | ;! > (or) 316 | ;! #f 317 | ;! > (or 123) 318 | ;! 123 319 | ;! > (or 123 456) 320 | ;! 123 321 | ;! > (or #f 456) 322 | ;! 456 323 | ;! > (or 123 456 789) 324 | ;! 123 325 | ;! > (def _r ()) 326 | ;! () 327 | ;! > (or 328 | ;! > (begin (set! _r (cons 1 _r)) #f) 329 | ;! > (begin (set! _r (cons 2 _r)) #f) 330 | ;! > (begin (set! _r (cons 3 _r)) 123) 331 | ;! > (begin (set! _r (cons 4 _r)) 456)) 332 | ;! 123 333 | ;! > _r 334 | ;! (3 2 1) 335 | 336 | (defun all (f xs) 337 | (if (nil? xs) 338 | #t 339 | (and (f (car xs)) 340 | (all f (cdr xs))))) 341 | ;! > (all num? (list)) 342 | ;! #t 343 | ;! > (all num? (list 1 2 3)) 344 | ;! #t 345 | ;! > (all num? (list 1 "2" 3)) 346 | ;! #f 347 | 348 | (defun any (f xs) 349 | (if (nil? xs) 350 | #f 351 | (or (f (car xs)) 352 | (any f (cdr xs))))) 353 | ;! > (any num? (list)) 354 | ;! #f 355 | ;! > (any num? (list 1 2 3)) 356 | ;! #t 357 | ;! > (any num? (list "1" 2 "3")) 358 | ;! #t 359 | ;! > (any num? (list "1" "2" "3")) 360 | ;! #f 361 | 362 | (defun partial (f . args-1) 363 | (fun args-2 364 | (apply f (append args-1 args-2)))) 365 | ;! > ((partial +)) 366 | ;! 0 367 | ;! > ((partial -) 1) 368 | ;! -1 369 | ;! > ((partial - 3) 1) 370 | ;! 2 371 | ;! > ((partial - 3 2) 1) 372 | ;! 0 373 | ;! > ((partial - 5 1) 2 3) 374 | ;! -1 375 | 376 | (defmacro quasiquote ls 377 | (*qq (car ls))) 378 | 379 | (defun *qq (x) 380 | (if (cons? x) 381 | (cond 382 | [(= (car x) 'unquote) 383 | (cadr x)] 384 | [(and (cons? (car x)) (= (caar x) 'unquote-splicing)) 385 | (list 'append (cadar x) (*qq (cdr x)))] 386 | [else 387 | (list 'cons (*qq (car x)) (*qq (cdr x)))]) 388 | (list 'quote x))) 389 | 390 | (defun *bind? (x) 391 | (and (cons? x) 392 | (cons? (cdr x)) 393 | (nil? (cddr x)) 394 | (sym? (car x)))) 395 | 396 | (defmacro let (binds . body) 397 | (cond 398 | [(sym? binds) 399 | `(named-let ,binds ,@body)] 400 | [(nil? binds) 401 | `(begin ,@body)] 402 | [(not (and (cons? binds) (*bind? (car binds)))) 403 | (error "Syntax error: expected (let ((name expr)...) body...)")] 404 | [else 405 | `((fun (,(caar binds)) (let ,(cdr binds) ,@body)) 406 | ,(cadar binds))])) 407 | 408 | (defmacro letrec (binds . body) 409 | (if (and (list? binds) (all *bind? binds)) 410 | (let ([vars (map (fun (x) `[,(car x) ()]) binds)] 411 | [inits (map (fun (x) `(set! ,(car x) ,(cadr x))) binds)]) 412 | `(let ,vars ,@inits ,@body)) 413 | (error "Syntax error: expected (letrec ((name expr)...) body...)"))) 414 | 415 | (defmacro named-let (sym binds . body) 416 | (if (and (list? binds) (all *bind? binds)) 417 | (let ([args (map car binds)]) 418 | `(let ,binds (letrec ([,sym (fun ,args ,@body)]) (,sym ,@args)))) 419 | (error "Syntax error: expected (named-let name ((name expr)...) body...)"))) 420 | 421 | ;! > (let ([_x 2] [_y 3]) (* _x _y)) 422 | ;! 6 423 | ;! > _x 424 | ;! fail 425 | ;! > (let _loop ([x 10] [sum 0]) 426 | ;! > (if (< 0 x) 427 | ;! > (_loop (- x 1) (+ sum x)) 428 | ;! > sum)) 429 | ;! 55 430 | ;! > _loop 431 | ;! fail 432 | ;! > (let ([x 3] [x (* x 4)] [x (+ x 5)]) x) 433 | ;! 17 434 | ;! > (letrec ([even? (fun (x) (if (= (% x 2) 0) #t (odd? (- x 1))))] 435 | ;! > [odd? (fun (x) (if (= (% x 2) 0) #f (even? (- x 1))))]) 436 | ;! > (list (even? 4) (even? 5) (odd? 6) (odd? 7))) 437 | ;! (#t #f #f #t) 438 | 439 | (defmacro when (cond . body) 440 | `(if ,cond (begin ,@body) ())) 441 | ;! > (when #f 123 456) 442 | ;! () 443 | ;! > (when #t 123 456) 444 | ;! 456 445 | 446 | (defmacro unless (cond . body) 447 | `(if ,cond () (begin ,@body))) 448 | ;! > (unless #f 123 456) 449 | ;! 456 450 | ;! > (unless #t 123 456) 451 | ;! () 452 | 453 | (defmacro let1 (var expr . body) 454 | `(let ([,var ,expr]) ,@body)) 455 | ;! > (let1 x 3 456 | ;! > (let1 x (* x 4) 457 | ;! > (let1 x (+ x 5) 458 | ;! > x))) 459 | ;! 17 460 | 461 | (defbuiltin call/cc (fun)) 462 | (defbuiltin never (fun . args)) 463 | 464 | (defmacro let/cc (k . body) 465 | `(call/cc (fun (,k) ,@body))) 466 | 467 | ;! > (+ 1 (let/cc cont (+ 10 (cont 100)))) 468 | ;! 101 469 | ;! > (+ 1 (let/cc cont (+ 10 100))) 470 | ;! 111 471 | ;! > (let ([x 10] [sum 0] [cont #f]) 472 | ;! > (let/cc k (set! cont k)) 473 | ;! > (when (< 0 x) 474 | ;! > (set! sum (+ sum x)) 475 | ;! > (set! x (- x 1)) 476 | ;! > (cont)) 477 | ;! > sum) 478 | ;! 55 479 | 480 | (defmacro shift (k . body) 481 | `(*shift (fun (,k) ,@body))) 482 | 483 | (defmacro reset body 484 | `(*reset (fun () ,@body))) 485 | 486 | (def *cont #f) 487 | 488 | (defun *abort (thunk) 489 | (never 490 | (fun () 491 | (let1 v (thunk) 492 | (*cont v))))) 493 | 494 | (defun *reset (thunk) 495 | (let1 cont *cont 496 | (let/cc k 497 | (set! *cont 498 | (fun (v) 499 | (set! *cont cont) 500 | (k v))) 501 | (*abort thunk)))) 502 | 503 | (defun *shift (f) 504 | (let/cc k 505 | (*abort 506 | (fun () 507 | (f 508 | (fun vs 509 | (reset (apply k vs)))))))) 510 | 511 | ;! > (reset 512 | ;! > (shift k (append '(1) (k))) 513 | ;! > (shift k (append '(2) (k))) 514 | ;! > (shift k (append '(3) (k))) 515 | ;! > '()) 516 | ;! (1 2 3) 517 | 518 | (defun success (v) (cons #t v)) 519 | (defun failure (v) (cons #f v)) 520 | 521 | (defun result (v) (cdr v)) 522 | 523 | (defun success? (v) (car v)) 524 | (defun failure? (v) (not (car v))) 525 | 526 | (defun force-success (v) 527 | (if (success? v) 528 | (result v) 529 | (error (result v)))) 530 | 531 | (defun force-failure (v) 532 | (if (failure? v) 533 | (result v) 534 | (error "force-failure"))) 535 | 536 | ;! > (force-success (success 123)) 537 | ;! 123 538 | ;! > (force-success (failure "error")) 539 | ;! fail 540 | ;! > (force-failure (success 123)) 541 | ;! fail 542 | ;! > (force-failure (failure "error")) 543 | ;! "error" 544 | 545 | (def result-unit success) 546 | 547 | (defun result-bind (m f) 548 | (if (success? m) (f (result m)) m)) 549 | 550 | (defmacro result-reify body 551 | `(reset (result-unit (begin ,@body)))) 552 | 553 | (defun result-reflect (m) 554 | (shift k (result-bind m k))) 555 | 556 | ;! > (result-reify 123) 557 | ;! (#t . 123) 558 | ;! > (result-reify (+ (result-reflect (success 123)) 456)) 559 | ;! (#t . 579) 560 | ;! > (result-reify (+ (result-reflect (failure "error")) 456)) 561 | ;! (#f . "error") 562 | ;! > (result-reify (let1 a (result-reify 123) (+ (result-reflect a) 1))) 563 | ;! (#t . 124) 564 | ;! > (result-reify (let1 a (result-reify (result-reflect (success 123))) (+ (result-reflect a) 1))) 565 | ;! (#t . 124) 566 | ;! > (result-reify (let1 a (result-reify (result-reflect (failure "error"))) (+ (result-reflect a) 1))) 567 | ;! (#f . "error") 568 | ;! > (result-reify (let1 a (result-reify (result-reflect (failure "error"))) a)) 569 | ;! (#t #f . "error") 570 | 571 | (def list-concat append) 572 | 573 | (defun list-count (xs) 574 | (let loop ([xs xs] [c 0]) 575 | (if (nil? xs) 576 | c 577 | (loop (cdr xs) (+ c 1))))) 578 | ;! > (list-count (list 1 3 4 5 6)) 579 | ;! 5 580 | 581 | (defun list-find (f ls) 582 | (cond 583 | [(nil? ls) ()] 584 | [(f (car ls)) (car ls)] 585 | [else (list-find f (cdr ls))])) 586 | ;! > (list-find num? (list "foo" 'bar 123 "baz" 456)) 587 | ;! 123 588 | ;! > (list-find num? (list "foo" 'bar "baz")) 589 | ;! () 590 | 591 | (defun list-lookup (k ls) 592 | (cond 593 | [(nil? ls) ()] 594 | [(= (caar ls) k) (cdar ls)] 595 | [else (list-lookup k (cdr ls))])) 596 | ;! > (list-lookup 2 '((1 . "foo") (2 . "bar") (3 . "baz"))) 597 | ;! "bar" 598 | ;! > (list-lookup 5 '((1 . "foo") (2 . "bar") (3 . "baz"))) 599 | ;! () 600 | 601 | (defun list-zip-with (f xs ys) 602 | (if (or (nil? xs) (nil? ys)) 603 | () 604 | (cons (f (car xs) (car ys)) 605 | (list-zip-with f (cdr xs) (cdr ys))))) 606 | 607 | (defun list-zip (xs ys) 608 | (list-zip-with cons xs ys)) 609 | 610 | ;! > (list-zip '(1 2 3) '(a b c)) 611 | ;! ((1 . a) (2 . b) (3 . c)) 612 | ;! > (list-zip '(1 2 3) '(x y)) 613 | ;! ((1 . x) (2 . y)) 614 | 615 | (def list-ref (flip nth)) 616 | ;! > (list-ref (list 4 3 2) 0) 617 | ;! 4 618 | 619 | (def list-at nth) 620 | 621 | (defbuiltin str chars) 622 | ;! > (str 102) 623 | ;! "f" 624 | ;! > (str 102 111 111 98 97 114) 625 | ;! "foobar" 626 | ;! > (str -1) 627 | ;! fail 628 | 629 | (defbuiltin str-char-at (str n)) 630 | ;! > (str-char-at "foobar" 0) 631 | ;! 102 632 | ;! > (str-char-at "foobar" 1) 633 | ;! 111 634 | ;! > (str-char-at "foobar" 8) 635 | ;! () 636 | 637 | (defbuiltin str-length (str)) 638 | ;! > (str-length "foobar") 639 | ;! 6 640 | ;! > (str-length "foobar" "baz") 641 | ;! fail 642 | 643 | (defun str->list (str) 644 | (map (partial str-char-at str) (iota 0 (str-length str)))) 645 | ;! > (str->list "foobar") 646 | ;! (102 111 111 98 97 114) 647 | 648 | (defun list->str (list) 649 | (apply str list)) 650 | ;! > (list->str (list 102 111 111 98 97 114)) 651 | ;! "foobar" 652 | 653 | (defbuiltin str-concat strs) 654 | ;! > (str-concat) 655 | ;! "" 656 | ;! > (str-concat "foo" "bar" "baz") 657 | ;! "foobarbaz" 658 | 659 | (defbuiltin substr (str n length)) 660 | ;! > (substr "foobar" 0 3) 661 | ;! "foo" 662 | ;! > (substr "foobar" 2 3) 663 | ;! "oba" 664 | ;! > (substr "foobar" 1 4) 665 | ;! "ooba" 666 | ;! > (substr "foobar" 1 10) 667 | ;! fail 668 | 669 | (defbuiltin sym->str (sym)) 670 | ;! > (sym->str 'foo-bar) 671 | ;! "foo-bar" 672 | 673 | (defbuiltin num->str (num)) 674 | ;! > (num->str 123) 675 | ;! "123" 676 | 677 | (defbuiltin str->num (num)) 678 | ;! > (str->num "456") 679 | ;! 456 680 | ;! > (str->num "foo") 681 | ;! () 682 | 683 | (defun str-escape (str) 684 | (list->str (*chars-escape (str->list str)))) 685 | 686 | (defun *chars-escape (chars) 687 | (if (nil? chars) 688 | () 689 | (let ([l (car chars)] 690 | [r (*chars-escape (cdr chars))]) 691 | (cond 692 | [(= l 92) (append '(92 92) r)] ; \\ 693 | [(= l 9) (append '(92 116) r)] ; \t 694 | [(= l 10) (append '(92 110) r)] ; \n 695 | [(= l 34) (append '(92 34) r)] ; \" 696 | [else (cons l r)])))) 697 | 698 | ;! > (str-escape "foo") 699 | ;! "foo" 700 | ;! > (str-escape "foo\"bar") 701 | ;! "foo\\\"bar" 702 | ;! > (str-escape "\t\t\n") 703 | ;! "\\t\\t\\n" 704 | ;! > (str-escape "peo\\ple") 705 | ;! "peo\\\\ple" 706 | 707 | (defun str-unescape (str) 708 | (list->str (*chars-unescape (str->list str)))) 709 | 710 | (defun *chars-unescape (chars) 711 | (cond 712 | [(or (nil? chars) (nil? (cdr chars))) chars] 713 | [(= (car chars) 92) 714 | (let ([l (cadr chars)] 715 | [r (*chars-unescape (cddr chars))]) 716 | (cond 717 | [(= l 92) (cons 92 r)] ; \\ 718 | [(= l 116) (cons 9 r)] ; \t 719 | [(= l 110) (cons 10 r)] ; \n 720 | [(= l 34) (cons 34 r)] ; \" 721 | [else (cons l r)]))] 722 | [else (cons (car chars) (*chars-unescape (cdr chars)))])) 723 | 724 | ;! > (str-unescape "foo") 725 | ;! "foo" 726 | ;! > (str-unescape "foo\\\"bar") 727 | ;! "foo\"bar" 728 | ;! > (str-unescape "\\t\\t\\n") 729 | ;! "\t\t\n" 730 | ;! > (str-unescape "peo\\\\ple") 731 | ;! "peo\\ple" 732 | 733 | (defun str-find-index (s pred) 734 | (let loop ([i 0]) 735 | (cond 736 | [(nil? (str-char-at s i)) ()] 737 | [(pred (str-char-at s i)) i] 738 | [else (loop (+ i 1))]))) 739 | 740 | (defun str-find-index-rev (s pred) 741 | (let loop ([i (- (str-length s) 1)]) 742 | (cond 743 | [(nil? (str-char-at s i)) ()] 744 | [(pred (str-char-at s i)) i] 745 | [else (loop (- i 1))]))) 746 | 747 | (defun space-char? (c) 748 | (or (= 32 c) (= 13 c) (= 10 c) (= 9 c))) 749 | 750 | (def non-space-char? 751 | (compose not space-char?)) 752 | 753 | (defun line-separator-char? (c) 754 | (or (= 13 c) (= 10 c))) 755 | 756 | ;! > (str-find-index "foo" non-space-char?) 757 | ;! 0 758 | ;! > (str-find-index " foo " non-space-char?) 759 | ;! 1 760 | ;! > (str-find-index " foo " non-space-char?) 761 | ;! 3 762 | ;! > (str-find-index "" non-space-char?) 763 | ;! () 764 | ;! > (str-find-index " " non-space-char?) 765 | ;! () 766 | ;! > (str-find-index-rev "foo" non-space-char?) 767 | ;! 2 768 | ;! > (str-find-index-rev " foo " non-space-char?) 769 | ;! 3 770 | ;! > (str-find-index-rev " foo " non-space-char?) 771 | ;! 5 772 | ;! > (str-find-index-rev "" non-space-char?) 773 | ;! () 774 | ;! > (str-find-index-rev " " non-space-char?) 775 | ;! () 776 | 777 | (defun str-trim-left (s) 778 | (let1 i (str-find-index s non-space-char?) 779 | (if (nil? i) 780 | "" 781 | (substr s i (- (str-length s) i))))) 782 | 783 | (defun str-trim-right (s) 784 | (let1 i (str-find-index-rev s non-space-char?) 785 | (if (nil? i) 786 | "" 787 | (substr s 0 (+ i 1))))) 788 | 789 | ;! > (str-trim-left "foo") 790 | ;! "foo" 791 | ;! > (str-trim-left " foo ") 792 | ;! "foo " 793 | ;! > (str-trim-left " \n foo") 794 | ;! "foo" 795 | ;! > (str-trim-left " ") 796 | ;! "" 797 | ;! > (str-trim-right "foo") 798 | ;! "foo" 799 | ;! > (str-trim-right " foo ") 800 | ;! " foo" 801 | ;! > (str-trim-right "foo \n ") 802 | ;! "foo" 803 | ;! > (str-trim-right " ") 804 | ;! "" 805 | 806 | (defun str-trim (s) 807 | (str-trim-left (str-trim-right s))) 808 | 809 | ;! > (str-trim " \n foo ") 810 | ;! "foo" 811 | 812 | (defun str-split (s pred) 813 | (let1 i (str-find-index s pred) 814 | (if (nil? i) 815 | (list s) 816 | (cons (substr s 0 i) (str-split (substr s (+ i 1) (- (str-length s) i 1)) pred))))) 817 | 818 | ;! > (str-split "foo" space-char?) 819 | ;! ("foo") 820 | ;! > (str-split "foo bar" space-char?) 821 | ;! ("foo" "bar") 822 | ;! > (str-split "foo bar\nbaz" space-char?) 823 | ;! ("foo" "bar" "baz") 824 | ;! > (str-split " foo bar " space-char?) 825 | ;! ("" "foo" "" "bar" "") 826 | ;! > (str-split "" space-char?) 827 | ;! ("") 828 | 829 | (defun str-lines (s) 830 | (str-split s line-separator-char?)) 831 | 832 | ;! > (str-lines "foo") 833 | ;! ("foo") 834 | ;! > (str-lines "foo\nbar\nbaz") 835 | ;! ("foo" "bar" "baz") 836 | ;! > (str-lines "\nfoo\n\nbar") 837 | ;! ("" "foo" "" "bar") 838 | 839 | (defbuiltin vec items) 840 | ;! > (vec 1 2 3) 841 | ;! (vec 1 2 3) 842 | ;! > (vec? (vec 1 2 3)) 843 | ;! #t 844 | 845 | (defbuiltin vec-make (length init)) 846 | ;! > (vec-make 5 #f) 847 | ;! (vec #f #f #f #f #f) 848 | 849 | (defbuiltin vec-get (vec n)) 850 | ;! > (vec-get (vec 4 9 3) 1) 851 | ;! 9 852 | ;! > (vec-get (vec 4 9 3) 4) 853 | ;! () 854 | 855 | (def vec-at (flip vec-get)) 856 | 857 | (defbuiltin vec-length (vec)) 858 | ;! > (vec-length (vec)) 859 | ;! 0 860 | ;! > (vec-length (vec 1 2 3 4 5)) 861 | ;! 5 862 | 863 | (defbuiltin vec-set! (vec n item)) 864 | ;! > (let1 v (vec-make 3 #f) 865 | ;! > (vec-set! v 0 #t) 866 | ;! > (vec-set! v 2 "k") 867 | ;! > v) 868 | ;! (vec #t #f "k") 869 | 870 | (defbuiltin vec-copy! (dest dest-start src src-start length)) 871 | ;! > (let ([fs (vec 0 1 2 3 4 5)] 872 | ;! > [ts (vec 6 7 8 9)]) 873 | ;! > (vec-copy! fs 2 ts 1 3) 874 | ;! > fs) 875 | ;! (vec 0 1 7 8 9 5) 876 | ;! > (let ([fs (vec 0 1 2 3 4 5)] 877 | ;! > [ts (vec 6 7 8 9)]) 878 | ;! > (vec-copy! fs 4 ts 1 3) 879 | ;! > fs) 880 | ;! fail 881 | ;! > (let ([fs (vec 0 1 2 3 4 5)] 882 | ;! > [ts (vec 6 7 8 9)]) 883 | ;! > (vec-copy! fs 1 ts 3 3) 884 | ;! > fs) 885 | ;! fail 886 | 887 | (defun vec->list (vec) 888 | (map (partial vec-get vec) (iota 0 (vec-length vec)))) 889 | ;! > (vec->list (vec 1 3 5 7)) 890 | ;! (1 3 5 7) 891 | 892 | (defun list->vec (list) 893 | (apply vec list)) 894 | ;! > (list->vec (list 1 3 5 7)) 895 | ;! (vec 1 3 5 7) 896 | 897 | (defmacro defrecord (name constructor-name predicate-name fields) 898 | (unless (and (sym? name) 899 | (or (sym? constructor-name) (= #f constructor-name)) 900 | (or (sym? predicate-name) (= #f predicate-name)) 901 | (list? fields) 902 | (all list? fields) 903 | (all (compose not nil?) fields) 904 | (all (partial all sym?) fields)) 905 | (error "Syntax error: expected (defrecord name predicate-name (fields...))")) 906 | (let ([field-names (map car fields)] 907 | [field-getter-names (map (fun (field) (and (cons? (cdr field)) (cadr field))) fields)] 908 | [field-setter-names (map (fun (field) (and (cons? (cdr field)) (cons? (cddr field)) (caddr field))) fields)] 909 | [field-indices (iota 1 (+ 1 (list-count fields)))] 910 | [constructor (and constructor-name `(defun ,constructor-name ,field-names (vec ',name ,@field-names)))] 911 | [predicate (and predicate-name `(defun ,predicate-name (v) (and (vec? v) (= ',name (vec-get v 0)))))] 912 | [getters (list-zip-with (fun (i f) (and f `(defun ,f (v) (vec-get v ,i)))) field-indices field-getter-names)] 913 | [setters (list-zip-with (fun (i f) (and f `(defun ,f (v x) (vec-set! v ,i x)))) field-indices field-setter-names)]) 914 | `(begin 915 | ,constructor 916 | ,predicate 917 | ,@(filter id getters) 918 | ,@(filter id setters)))) 919 | 920 | ;! > (defrecord point point point? 921 | ;! > ([x point-x] 922 | ;! > [y point-y set-point-y!])) 923 | ;! () 924 | ;! > (def _p (point 12 34)) 925 | ;! () 926 | ;! > (list (point? _p) (point? 123)) 927 | ;! (#t #f) 928 | ;! > (list (point-x _p) (point-y _p)) 929 | ;! (12 34) 930 | ;! > (set-point-y! _p 56) 931 | ;! () 932 | ;! > (list (point-x _p) (point-y _p)) 933 | ;! (12 56) 934 | 935 | (defbuiltin read-file-text (filepath)) 936 | (defbuiltin write-file-text (filepath str)) 937 | 938 | (defbuiltin read-console-line ()) 939 | (defbuiltin write-console (str)) 940 | 941 | (defun inspect (x) 942 | (cond 943 | [(num? x) (num->str x)] 944 | [(sym? x) (sym->str x)] 945 | [(str? x) (str-concat "\"" (str-escape x) "\"")] 946 | [(cons? x) (let ([l (car x)] 947 | [r (cdr x)] 948 | [a (list-lookup l *syntax-sugar)]) 949 | (if (and (not (nil? a)) (cons? r) (nil? (cdr r))) 950 | (str-concat a (inspect (car r))) 951 | (str-concat "(" (*inspect-cons l r) ")")))] 952 | [(nil? x) "()"] 953 | [(= #t x) "#t"] 954 | [(= #f x) "#f"] 955 | [(proc? x) ""] 956 | [(meta? x) ""] 957 | [(vec? x) (inspect (cons 'vec (vec->list x)))] 958 | [else (error)])) 959 | 960 | (def *syntax-sugar 961 | '((quote . "'") 962 | (quasiquote . "`") 963 | (unquote . ",") 964 | (unquote-splicing . ",@"))) 965 | 966 | (defun *inspect-cons (a b) 967 | (cond 968 | [(nil? b) (inspect a)] 969 | [(cons? b) (str-concat (inspect a) " " (*inspect-cons (car b) (cdr b)))] 970 | [else (str-concat (inspect a) " . " (inspect b))])) 971 | 972 | ;! > (inspect 123) 973 | ;! "123" 974 | ;! > (inspect 'foo) 975 | ;! "foo" 976 | ;! > (inspect "Hello, World!\n") 977 | ;! "\"Hello, World!\\n\"" 978 | ;! > (inspect ()) 979 | ;! "()" 980 | ;! > (inspect '(1)) 981 | ;! "(1)" 982 | ;! > (inspect '(1 a "b")) 983 | ;! "(1 a \"b\")" 984 | ;! > (inspect '(foo . bar)) 985 | ;! "(foo . bar)" 986 | ;! > (inspect '(foo bar . baz)) 987 | ;! "(foo bar . baz)" 988 | ;! > (map inspect (list ''foo ''(bar baz))) 989 | ;! ("'foo" "'(bar baz)") 990 | ;! > (inspect '`(foo ,bar ,@baz)) 991 | ;! "`(foo ,bar ,@baz)" 992 | ;! > (inspect '(quote foo bar)) 993 | ;! "(quote foo bar)" 994 | ;! > (inspect '(quote . foo)) 995 | ;! "(quote . foo)" 996 | ;! > (map inspect '(#t #f)) 997 | ;! ("#t" "#f") 998 | ;! > (map inspect (list (fun ()) = (macro ()) def)) 999 | ;! ("" "" "" "") 1000 | ;! > (inspect (vec 1 2 3)) 1001 | ;! "(vec 1 2 3)" 1002 | 1003 | (defun print strs 1004 | (map write-console strs) 1005 | ()) 1006 | 1007 | (defun println strs 1008 | (map write-console strs) 1009 | (write-console "\n") 1010 | ()) 1011 | 1012 | (defun p xs 1013 | (apply println (map inspect xs))) 1014 | 1015 | (def args ((builtin args))) 1016 | 1017 | (defbuiltin eval (s)) 1018 | ;! > (force-success (eval '(+ 1 2 3))) 1019 | ;! 6 1020 | ;! > (force-success (eval '(error))) 1021 | ;! fail 1022 | 1023 | (defbuiltin macroexpand (s)) 1024 | (defbuiltin macroexpand-1 (s)) 1025 | ;! > (force-success (macroexpand 123)) 1026 | ;! 123 1027 | ;! > (force-success (macroexpand '(defun foo (x y) (+ x y)))) 1028 | ;! (def foo (fun (x y) (+ x y))) 1029 | ;! > (def _skip (macro (a . b) b)) 1030 | ;! () 1031 | ;! > (force-success (macroexpand '(_skip 12 _skip 34 list 56 78))) 1032 | ;! (list 56 78) 1033 | ;! > (force-success (macroexpand-1 '(_skip 12 _skip 34 list 56 78))) 1034 | ;! (_skip 34 list 56 78) 1035 | ;! > (force-success (macroexpand '(list 12 (_skip 34 list 56 78)))) 1036 | ;! (list 12 (list 56 78)) 1037 | ;! > (force-success (macroexpand-1 '(list 12 (_skip 34 list 56 78)))) 1038 | ;! (list 12 (_skip 34 list 56 78)) 1039 | ;! > (force-success (macroexpand '(_skip))) 1040 | ;! fail 1041 | -------------------------------------------------------------------------------- /contrib/parser-combinators-stream.lisp: -------------------------------------------------------------------------------- 1 | (defun parse-just (p stream) 2 | (let1 p (p-reduce (fun (x _) x) p ps-eof) 3 | (result-reify 4 | (car (result-reflect (parse p stream)))))) 5 | 6 | ;! > (defun ps-test (p str) 7 | ;! > (let1 r (p (str->stream str)) 8 | ;! > (and r (cons (car r) (stream->str (cdr r)))))) 9 | ;! () 10 | 11 | ; Predicates 12 | 13 | (defun char-class (s) 14 | (let ([inverse? (= (str-char-at s 0) 94)] 15 | [ls (str->list s)] 16 | [fs (*char-class (if inverse? (cdr ls) ls))]) 17 | (if inverse? 18 | (fun (i) (all (fun (f) (not (f i))) fs)) 19 | (fun (i) (any (fun (f) (f i)) fs))))) 20 | 21 | (defun *char-class (ls) 22 | (cond 23 | [(nil? ls) ()] 24 | [(or (nil? (cdr ls)) (nil? (cddr ls))) (map *char-class-unit ls)] 25 | [(= (nth 1 ls) 45) (cons (*char-class-range (nth 0 ls) (nth 2 ls)) 26 | (*char-class (cdddr ls)))] 27 | [else (cons (*char-class-unit (car ls)) 28 | (*char-class (cdr ls)))])) 29 | 30 | (defun *char-class-unit (x) 31 | (fun (i) (= i x))) 32 | 33 | (defun *char-class-range (x y) 34 | (fun (i) (<= x i y))) 35 | 36 | ;! > (map (char-class "a-fstx-z") (str->list "abcfgtuwy")) 37 | ;! (#t #t #t #t #f #t #f #f #t) 38 | ;! > (map (char-class "^a-fstx-z") (str->list "abcfgtuwy")) 39 | ;! (#f #f #f #f #t #f #t #t #f) 40 | 41 | ; Parser combinators 42 | 43 | (defun ps-any (i) 44 | (and (not (= (stream-peek i) 'eof)) (cons (stream-peek i) (stream-next i)))) 45 | ;! > (ps-test ps-any "abc") 46 | ;! (97 . "bc") 47 | ;! > (ps-test ps-any "") 48 | ;! #f 49 | 50 | (defun ps-eof (i) 51 | (and (= (stream-peek i) 'eof) (cons () i))) 52 | ;! > (ps-test ps-eof "") 53 | ;! (() . "") 54 | ;! > (ps-test ps-eof "abc") 55 | ;! #f 56 | 57 | ; p-unit 58 | ;! > (ps-test (p-unit "Hello") "abc") 59 | ;! ("Hello" . "abc") 60 | 61 | ; p-bind 62 | ;! > (ps-test (p-bind ps-any (fun (a) 63 | ;! > (p-bind ps-any (fun (b) 64 | ;! > (p-unit (cons a b)))))) "abc") 65 | ;! ((97 . 98) . "c") 66 | 67 | ; p-fail 68 | ;! > (ps-test p-fail "abc") 69 | ;! #f 70 | ;! > (ps-test (p-bind ps-any (fun (a) 71 | ;! > (p-bind p-fail (fun (b) 72 | ;! > (p-unit (cons a b)))))) "abc") 73 | ;! #f 74 | 75 | (def ps-char 76 | (p-map str ps-any)) 77 | ; p-map 78 | ;! > (ps-test ps-char "abc") 79 | ;! ("a" . "bc") 80 | 81 | (defun ps-if (f) 82 | (p-where f ps-any)) 83 | ; p-where 84 | ;! > (ps-test (ps-if (char-class "ab")) "abc") 85 | ;! (97 . "bc") 86 | ;! > (ps-test (ps-if (char-class "ab")) "def") 87 | ;! #f 88 | 89 | (defun ps-char-if (f) 90 | (p-map str (ps-if f))) 91 | ;! > (ps-test (ps-char-if (char-class "ab")) "abc") 92 | ;! ("a" . "bc") 93 | 94 | ; p-or, p-choice 95 | ;! > (let ([ab (ps-char-if (char-class "ab"))] 96 | ;! > [ac (ps-char-if (char-class "ac"))] 97 | ;! > [add-suffix (fun (s) (str-concat s "-"))] 98 | ;! > [p (p-choice ab (p-map add-suffix ac))]) 99 | ;! > (list (ps-test p "abcd") 100 | ;! > (ps-test p "bcda") 101 | ;! > (ps-test p "cdab") 102 | ;! > (ps-test p "dabc"))) 103 | ;! (("a" . "bcd") ("b" . "cda") ("c-" . "dab") #f) 104 | 105 | ; p-cons, p-nil, p-seq 106 | ;! > (let1 p (p-seq (ps-char-if (char-class "ab")) 107 | ;! > (ps-char-if (char-class "12")) 108 | ;! > (ps-char-if (char-class "xy"))) 109 | ;! > (list (ps-test p "c2xo") 110 | ;! > (ps-test p "a3yp") 111 | ;! > (ps-test p "b1zq") 112 | ;! > (ps-test p "a1xr"))) 113 | ;! (#f #f #f (("a" "1" "x") . "r")) 114 | 115 | (defun ps-list (xs) 116 | (apply p-seq (map (fun (x) (ps-if (fun (y) (= x y)))) xs))) 117 | 118 | (defun ps-str (s) 119 | (p-map (const s) (ps-list (str->list s)))) 120 | 121 | ;! > (ps-test (ps-str "foo") "bar") 122 | ;! #f 123 | ;! > (ps-test (ps-str "bar") "bar") 124 | ;! ("bar" . "") 125 | ;! > (ps-test (ps-str "baz") "bar") 126 | ;! #f 127 | 128 | ; p-many, p-some 129 | ;! > (let ([p0 (p-many (ps-str "a"))] 130 | ;! > [p1 (p-some (ps-str "a"))]) 131 | ;! > (list (ps-test p0 "") 132 | ;! > (ps-test p0 "a") 133 | ;! > (ps-test p0 "aaa") 134 | ;! > (ps-test p0 "aabb") 135 | ;! > (ps-test p1 "") 136 | ;! > (ps-test p1 "a") 137 | ;! > (ps-test p1 "aabb"))) 138 | ;! ((() . "") (("a") . "") (("a" "a" "a") . "") (("a" "a") . "bb") #f (("a") . "") (("a" "a") . "bb")) 139 | 140 | ; p-reduce 141 | ;! > (ps-test (p-reduce + (p-map (fun (n) (* n 10000)) ps-any) 142 | ;! > (p-map (fun (n) (* n 100)) ps-any) 143 | ;! > ps-any) "abcdef") 144 | ;! (979899 . "def") 145 | 146 | (defun ps-str-while (f) 147 | (p-map (fun (ls) (apply str ls)) (p-some (ps-if f)))) 148 | ;! > (ps-test (ps-str-while (char-class "abc")) "ababcbadcba") 149 | ;! ("ababcba" . "dcba") 150 | ;! > (ps-test (ps-str-while (char-class "abc")) "defabcdef") 151 | ;! #f 152 | -------------------------------------------------------------------------------- /contrib/parser-combinators.lisp: -------------------------------------------------------------------------------- 1 | ; (input) => (result . input) | #f 2 | ; tested in parser-combinators-stream 3 | 4 | (defun parse (p i) 5 | (let1 r (p i) 6 | (if r 7 | (success r) 8 | (failure "Parse error")))) 9 | 10 | (defun p-unit (x) 11 | (fun (i) (cons x i))) 12 | 13 | (defun p-bind (m f) 14 | (fun (i) 15 | (let1 x (m i) 16 | (and x ((f (car x)) (cdr x)))))) 17 | 18 | (def p-fail 19 | (fun (i) #f)) 20 | 21 | (defmacro p-reify body 22 | `(reset (p-unit (begin ,@body)))) 23 | 24 | (defun p-reflect (m) 25 | (shift k (p-bind m k))) 26 | 27 | (defmacro p-lazy (p) 28 | `(fun (i) (,p i))) 29 | 30 | (defun p-map (f p) 31 | (p-reify 32 | (let1 x (p-reflect p) 33 | (f x)))) 34 | 35 | (defun p-where (f p) 36 | (fun (i) 37 | (let1 x (p i) 38 | (and x (f (car x)) x)))) 39 | 40 | (defun p-or (p q) 41 | (fun (i) 42 | (or (p i) (q i)))) 43 | 44 | (defun p-cons (p q) 45 | (p-reify 46 | (let ([x (p-reflect p)] 47 | [y (p-reflect q)]) 48 | (cons x y)))) 49 | 50 | (def p-nil (p-unit ())) 51 | 52 | (defun p-choice ps 53 | (foldr p-or p-fail ps)) 54 | 55 | (defun p-seq ps 56 | (foldr p-cons p-nil ps)) 57 | 58 | (defun p-some (p) 59 | (p-cons p (p-many p))) 60 | 61 | (defun p-many (p) 62 | (p-lazy 63 | (p-choice (p-some p) p-nil))) 64 | 65 | (defun p-reduce (f . args) 66 | (p-map (partial apply f) (apply p-seq args))) 67 | -------------------------------------------------------------------------------- /contrib/stream.lisp: -------------------------------------------------------------------------------- 1 | (defrecord stream *stream stream? 2 | ([body *stream-body *stream-set-body!] ; () | (cons item next-stream) 3 | [forward *stream-forward])) 4 | 5 | (defun stream (input) 6 | (letrec ([stream-head ()] 7 | [forward 8 | (fun () 9 | (let1 next-stream-head (*stream () forward) 10 | (*stream-set-body! stream-head (cons (input) next-stream-head)) 11 | (set! stream-head next-stream-head)))]) 12 | (set! stream-head (*stream () forward)) 13 | stream-head)) 14 | 15 | (defun stream-peek (s) 16 | (when (nil? (*stream-body s)) ((*stream-forward s))) 17 | (car (*stream-body s))) 18 | 19 | (defun stream-next (s) 20 | (if (= (stream-peek s) 'eof) 21 | s 22 | (cdr (*stream-body s)))) 23 | 24 | (defun stream-get (s) 25 | (if (stream-eof? s) 26 | (failure "eof") 27 | (let ([r (stream-peek s)] 28 | [s (stream-next s)]) 29 | (success (cons r s))))) 30 | 31 | (defun stream-take (n s) 32 | (let loop ([n n] 33 | [s s] 34 | [ret ()]) 35 | (if (= n 0) 36 | (success (reverse ret)) 37 | (let1 r (stream-get s) 38 | (if (success? r) 39 | (loop (- n 1) 40 | (cdr (result r)) 41 | (cons (car (result r)) ret)) 42 | r))))) 43 | 44 | (defun stream-eof? (s) 45 | (= (stream-peek s) 'eof)) 46 | 47 | ;! > (def _x 0) 48 | ;! () 49 | ;! > (def _s1 (stream (fun () (set! _x (+ _x 1)) _x))) 50 | ;! () 51 | ;! > (stream-peek _s1) 52 | ;! 1 53 | ;! > (stream-peek _s1) 54 | ;! 1 55 | ;! > (def _s2 (stream-next _s1)) 56 | ;! () 57 | ;! > (cons (stream-peek _s1) (stream-peek _s2)) 58 | ;! (1 . 2) 59 | ;! > (set! _s1 (stream-next (stream-next _s1))) 60 | ;! () 61 | ;! > (cons (stream-peek _s1) (stream-peek _s2)) 62 | ;! (3 . 2) 63 | ;! > (set! _s1 (force-success (stream-get _s1))) 64 | ;! () 65 | ;! > (cons (car _s1) (stream-peek (cdr _s1))) 66 | ;! (3 . 4) 67 | ;! > (force-success (stream-take 4 _s2)) 68 | ;! (2 3 4 5) 69 | 70 | (defun list->stream (ls) 71 | (stream 72 | (fun () 73 | (if (nil? ls) 74 | 'eof 75 | (let1 r (car ls) 76 | (set! ls (cdr ls)) 77 | r))))) 78 | ;! > (force-success (stream-take 4 (list->stream (list 1 2 3 4 5)))) 79 | ;! (1 2 3 4) 80 | 81 | (defun stream->list (s) 82 | (if (stream-eof? s) 83 | () 84 | (cons (stream-peek s) (stream->list (stream-next s))))) 85 | ;! > (stream->list (list->stream (list 1 2 3))) 86 | ;! (1 2 3) 87 | 88 | (defun str->stream (str) 89 | (let1 i 0 90 | (stream 91 | (fun () 92 | (if (< i (str-length str)) 93 | (let1 r (str-char-at str i) 94 | (set! i (+ i 1)) 95 | r) 96 | 'eof))))) 97 | ;! > (force-success (stream-take 3 (str->stream "abc"))) 98 | ;! (97 98 99) 99 | ;! > (force-success (stream-take 4 (str->stream "abc"))) 100 | ;! fail 101 | 102 | (defun stream->str (s) 103 | (apply str (stream->list s))) 104 | ;! > (stream->str (list->stream (list 97 98 99))) 105 | ;! "abc" 106 | -------------------------------------------------------------------------------- /contrib/tbl.lisp: -------------------------------------------------------------------------------- 1 | (defun *str-hash (str) 2 | (let loop ([i 0] 3 | [r 0] 4 | [p 1]) 5 | (if (<= (str-length str) i) 6 | r 7 | (loop (+ i 1) 8 | (+ r (* p (str-char-at str i))) 9 | (% (* p 257) 2038177))))) 10 | 11 | (def *tbl-capacity-provider 12 | (list->stream (list 17 31 61 101 211 421 877 1663 3323 6871 14173 28439 57457 112771 232607))) 13 | 14 | (def *tbl-threshold 0.8) 15 | 16 | (defun *tbl-f (hash M) 17 | (% hash M)) 18 | 19 | (defun *tbl-g (hash M) 20 | (+ 1 (% hash (- M 1)))) 21 | 22 | (defun *tbl-h (hash M i) 23 | (% (+ (*tbl-f hash M) 24 | (* i (*tbl-g hash M))) 25 | M)) 26 | 27 | (defrecord tbl *tbl tbl? 28 | ([capacity *tbl-capacity *tbl-set-capacity!] 29 | [length-total *tbl-length-total *tbl-set-length-total!] 30 | [length-removed *tbl-length-removed *tbl-set-length-removed!] 31 | [payload *tbl-payload *tbl-set-payload!])) 32 | 33 | ; = (vec ...) 34 | ; = (key . value) | key | #f 35 | 36 | (defun tbl () 37 | (let1 t (*tbl () () () ()) 38 | (tbl-clear! t) 39 | t)) 40 | 41 | (defun tbl-clear! (t) 42 | (*tbl-set-capacity! t *tbl-capacity-provider) 43 | (*tbl-set-length-total! t 0) 44 | (*tbl-set-length-removed! t 0) 45 | (*tbl-set-payload! t (vec-make (stream-peek *tbl-capacity-provider) #f))) 46 | 47 | (defun tbl-justify! (tbl additional-capacity) 48 | (let ([payload-required-length (+ (*tbl-length-total tbl) additional-capacity)] 49 | [required-length (- payload-required-length (*tbl-length-removed tbl))] 50 | [usable-length (* (stream-peek (*tbl-capacity tbl)) *tbl-threshold)]) 51 | ; NOTE: tbl never shrinks. 52 | (when (< usable-length payload-required-length) 53 | (let ([payload (*tbl-payload tbl)] 54 | [new-capacity (*tbl-forward-capacity (*tbl-capacity tbl) required-length)] 55 | [new-payload (vec-make (stream-peek new-capacity) #f)]) 56 | (*tbl-set-capacity! tbl new-capacity) 57 | (*tbl-set-length-total! tbl 0) 58 | (*tbl-set-length-removed! tbl 0) 59 | (*tbl-set-payload! tbl new-payload) 60 | (*tbl-migrate! payload tbl))))) 61 | 62 | (defun *tbl-forward-capacity (s length) 63 | (cond 64 | [(= 'eof (stream-peek s)) (error "Too much elements")] 65 | [(< (* (stream-peek s) *tbl-threshold) length) (*tbl-forward-capacity (stream-next s) length)] 66 | [else s])) 67 | 68 | (defun *tbl-migrate! (payload tbl) 69 | (let loop ([i 0]) 70 | (when (< i (vec-length payload)) 71 | (let1 item (vec-get payload i) 72 | (when (cons? item) 73 | (tbl-insert! tbl (car item) (cdr item))) 74 | (loop (+ i 1)))))) 75 | 76 | (defun *tbl-find-index (tbl key) 77 | (let ([M (stream-peek (*tbl-capacity tbl))] 78 | [hash (*str-hash key)] 79 | [match? (fun (v) 80 | (or (not v) 81 | (= v key) 82 | (and (cons? v) (= (car v) key))))]) 83 | (let loop ([i 0]) 84 | (let1 index (*tbl-h hash M i) 85 | (if (match? (vec-get (*tbl-payload tbl) index)) 86 | index 87 | (loop (+ i 1))))))) 88 | 89 | (defun *tbl-find (tbl key) 90 | (vec-get (*tbl-payload tbl) (*tbl-find-index tbl key))) 91 | 92 | (defun tbl-contains? (tbl key) 93 | (cons? (*tbl-find tbl key))) 94 | 95 | (defun tbl-find (tbl key) 96 | (let1 r (*tbl-find tbl key) 97 | (if (cons? r) (cdr r) ()))) 98 | 99 | (defun tbl-insert! (tbl key value) 100 | (tbl-justify! tbl 1) 101 | (let ([index (*tbl-find-index tbl key)] 102 | [prev (vec-get (*tbl-payload tbl) index)]) 103 | (vec-set! (*tbl-payload tbl) index (cons key value)) 104 | (cond 105 | [(not prev) (*tbl-set-length-total! tbl (+ (*tbl-length-total tbl) 1))] 106 | [(str? prev) (*tbl-set-length-removed! tbl (- (*tbl-length-removed tbl) 1))]))) 107 | 108 | (defun tbl-remove! (tbl key) 109 | (let ([index (*tbl-find-index tbl key)] 110 | [prev (vec-get (*tbl-payload tbl) index)]) 111 | (when (cons? prev) 112 | (vec-set! (*tbl-payload tbl) index key) 113 | (*tbl-set-length-removed! tbl (+ (*tbl-length-removed tbl) 1))))) 114 | 115 | ;! > (tbl? (tbl)) 116 | ;! #t 117 | ;! > (tbl? 123) 118 | ;! #f 119 | ;! > (def _t (tbl)) 120 | ;! () 121 | ;! > (tbl-contains? _t "foo") 122 | ;! #f 123 | ;! > (tbl-insert! _t "foo" 123) 124 | ;! () 125 | ;! > (tbl-contains? _t "foo") 126 | ;! #t 127 | ;! > (tbl-find _t "foo") 128 | ;! 123 129 | ;! > (list (tbl-contains? _t "bar") (tbl-find _t "bar")) 130 | ;! (#f ()) 131 | ;! > (tbl-insert! _t "bar" 456) 132 | ;! () 133 | ;! > (list (tbl-find _t "foo") (tbl-find _t "bar") (tbl-find _t "baz")) 134 | ;! (123 456 ()) 135 | ;! > (tbl-remove! _t "foo") 136 | ;! () 137 | ;! > (tbl-remove! _t "baz") 138 | ;! () 139 | ;! > (list (tbl-find _t "foo") (tbl-find _t "bar") (tbl-find _t "baz")) 140 | ;! (() 456 ()) 141 | ;! > (begin (for (iota 0 1000) (fun (i) (tbl-insert! _t (num->str i) (* i 2)))) ()) 142 | ;! () 143 | ;! > (foldr + 0 (map (fun (i) (tbl-find _t (num->str i))) (iota 0 301))) 144 | ;! 90300 145 | 146 | (defun *tbl-information (tbl) 147 | (list 'tbl-information 148 | (list 'capacity (stream-peek (*tbl-capacity tbl))) 149 | (list 'used (*tbl-length-total tbl)) 150 | (list 'removed (*tbl-length-removed tbl)) 151 | (list 'items (filter cons? (vec->list (*tbl-payload tbl)))))) 152 | -------------------------------------------------------------------------------- /examples/backtrack.lisp: -------------------------------------------------------------------------------- 1 | (def fail (fun () (error "Cannot backtrack"))) 2 | 3 | (defun amb-proc l 4 | (let1 former-fail fail 5 | (if (nil? l) 6 | (fail) 7 | (call/cc (fun (k) 8 | (set! fail (fun () 9 | (set! fail former-fail) 10 | (k (apply amb-proc (cdr l))))) 11 | (k ((car l)))))))) 12 | 13 | 14 | (defmacro amb values 15 | (cons 'amb-proc (map (fun (v) `(fun () ,v)) values))) 16 | 17 | (p 18 | (let ([i (amb 2 3 4)] 19 | [j (amb 5 6 7)]) 20 | (if (= (* i j) 18) 21 | (cons i j) 22 | (amb)))) 23 | -------------------------------------------------------------------------------- /examples/conways-gol.lisp: -------------------------------------------------------------------------------- 1 | (def w 13) 2 | (def h 13) 3 | (def step 9) 4 | (def board 5 | '((_ _ _ _ _ _ _ _ _ _ _ _ _) 6 | (_ _ _ _ _ _ _ _ _ _ _ _ _) 7 | (_ _ @ @ @ @ @ @ _ @ @ _ _) 8 | (_ _ @ @ @ @ @ @ _ @ @ _ _) 9 | (_ _ _ _ _ _ _ _ _ @ @ _ _) 10 | (_ _ @ @ _ _ _ _ _ @ @ _ _) 11 | (_ _ @ @ _ _ _ _ _ @ @ _ _) 12 | (_ _ @ @ _ _ _ _ _ @ @ _ _) 13 | (_ _ @ @ _ _ _ _ _ _ _ _ _) 14 | (_ _ @ @ _ @ @ @ @ @ @ _ _) 15 | (_ _ @ @ _ @ @ @ @ @ @ _ _) 16 | (_ _ _ _ _ _ _ _ _ _ _ _ _) 17 | (_ _ _ _ _ _ _ _ _ _ _ _ _))) 18 | 19 | ;;;;;;;;;;; 20 | 21 | (defun gol-step (h w board) 22 | (defun at (y x) 23 | (if (or (not (<= 0 y (- h 1))) 24 | (not (<= 0 x (- w 1)))) 25 | #f 26 | (= (nth x (nth y board)) '@))) 27 | 28 | (defun count-true l 29 | (let loop ([l l] 30 | [k 0]) 31 | (if (nil? l) 32 | k 33 | (loop (cdr l) 34 | (if (car l) (+ k 1) k))))) 35 | 36 | (for (iota 0 h) (fun (y) 37 | (for (iota 0 w) (fun (x) 38 | (let ([y- (- y 1)] 39 | [y+ (+ y 1)] 40 | [x- (- x 1)] 41 | [x+ (+ x 1)] 42 | [current (at y x)] 43 | [border (count-true (at y- x-) (at y- x) (at y- x+) (at y x-) (at y x+) (at y+ x-) (at y+ x) (at y+ x+))]) 44 | (cond 45 | [(and (not current) (= border 3)) '@] 46 | [(and current (<= 2 border 3)) '@] 47 | [else '_]))))))) 48 | 49 | (defun print-board (board) 50 | (map (fun (row) (apply p row)) board) 51 | (println)) 52 | 53 | (defun gol (h w step board) 54 | (let loop ([board board] 55 | [step step]) 56 | (unless (= step 0) 57 | (print-board board) 58 | (loop (gol-step h w board) (- step 1))))) 59 | 60 | (gol h w step board) 61 | -------------------------------------------------------------------------------- /examples/fizzbuzz.lisp: -------------------------------------------------------------------------------- 1 | (let loop ([i 1]) 2 | (println 3 | (cond 4 | [(= 0 (% i 3) (% i 5)) "FizzBuzz"] 5 | [(= 0 (% i 3)) "Fizz"] 6 | [(= 0 (% i 5)) "Buzz"] 7 | [else (num->str i)])) 8 | (when (< i 40) 9 | (loop (+ i 1)))) 10 | -------------------------------------------------------------------------------- /examples/hello.lisp: -------------------------------------------------------------------------------- 1 | (println "Hello, World!") 2 | -------------------------------------------------------------------------------- /examples/quine.lisp: -------------------------------------------------------------------------------- 1 | ((fun (s) (p `(,s ',s))) '(fun (s) (p `(,s ',s)))) 2 | -------------------------------------------------------------------------------- /gentest: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | 3 | Block = Struct.new("Block", :label, :text, :location) 4 | 5 | @buf = "" 6 | 7 | def main() 8 | interpret = -> method { -> input, result { 9 | if result == "fail" 10 | "#{method}_FAILURE #{input.lines.count}\n#{input}" 11 | else 12 | "#{method}_SUCCESS #{input.lines.count} #{result.lines.count}\n#{input}\n#{result}" 13 | end 14 | } } 15 | 16 | build "testsuites/parser", { 17 | input: /^> ?(.*)$/ 18 | }, { 19 | [:input, :raw] => interpret["PARSE"] 20 | } 21 | 22 | build "testsuites/compiler", { 23 | input: /^> ?(.*)$/ 24 | }, { 25 | [:input, :raw] => interpret["COMPILE"] 26 | } 27 | 28 | build "testsuites/vm", { 29 | input: /^> ?(.*)$/ 30 | }, { 31 | [:input, :raw] => interpret["EVAL"] 32 | } 33 | 34 | lisp_patterns = { 35 | test_input: /^;! ?> ?(.*)$/, 36 | test_result: /^;! ?(.*)$/ 37 | } 38 | lisp_handlers = { 39 | [:raw] => -> raw { raw.chomp!; "EVAL_ALL #{raw.lines.count}\n#{raw}".chomp }, 40 | [:test_input, :test_result] => interpret["EVAL"] 41 | } 42 | 43 | build "boot.lisp", lisp_patterns, lisp_handlers 44 | build "contrib/stream.lisp", lisp_patterns, lisp_handlers 45 | build "contrib/parser-combinators.lisp", lisp_patterns, lisp_handlers 46 | build "contrib/parser-combinators-stream.lisp", lisp_patterns, lisp_handlers 47 | build "contrib/tbl.lisp", lisp_patterns, lisp_handlers 48 | 49 | open("test", "w") {|f| f.write @buf } 50 | end 51 | 52 | def build(file, p, e) 53 | emit(read_block(file, p), e) 54 | end 55 | 56 | def read_block(file, patterns) 57 | blocks = [] 58 | last = nil 59 | 60 | IO.readlines(file).each_with_index do |line, i| 61 | label = :raw 62 | line.chomp! 63 | for lbl, pat in patterns do 64 | next if pat !~ line 65 | label, line = lbl, $1 66 | break 67 | end 68 | 69 | if !last || last.label != label 70 | last = Block.new(label, line, "#{file}:#{i + 1}") 71 | blocks << last 72 | else 73 | last.text << "\n" + line 74 | end 75 | end 76 | 77 | blocks.each {|block| block.text.chomp! } 78 | end 79 | 80 | def emit(blocks, patterns) 81 | while !blocks.empty? 82 | match = false 83 | for labels, body in patterns do 84 | next if blocks.size < labels.size 85 | next unless blocks.take(labels.size).zip(labels).all? {|block, label| block.label == label} 86 | @buf << "#{blocks[0].location}\n" 87 | @buf << body.(*blocks.take(labels.size).map(&:text)) + "\n" 88 | blocks = blocks.drop(labels.size) 89 | match = true 90 | break 91 | end 92 | raise "Cannot handle blocks: #{blocks}" unless match 93 | end 94 | end 95 | 96 | main 97 | -------------------------------------------------------------------------------- /test: -------------------------------------------------------------------------------- 1 | testsuites/parser:1 2 | PARSE_SUCCESS 1 1 3 | foo 4 | foo 5 | testsuites/parser:4 6 | PARSE_SUCCESS 1 1 7 | abc123 8 | abc123 9 | testsuites/parser:7 10 | PARSE_SUCCESS 1 1 11 | foo-bar 12 | foo-bar 13 | testsuites/parser:10 14 | PARSE_SUCCESS 1 1 15 | *foo* 16 | *foo* 17 | testsuites/parser:13 18 | PARSE_SUCCESS 1 1 19 | x 20 | x 21 | testsuites/parser:16 22 | PARSE_SUCCESS 1 1 23 | x1-y2!$%&*+-/:<=>?@^_~ 24 | x1-y2!$%&*+-/:<=>?@^_~ 25 | testsuites/parser:19 26 | PARSE_FAILURE 1 27 | . 28 | testsuites/parser:22 29 | PARSE_SUCCESS 1 1 30 | the-Answer-to-the-Ultimate-Question 31 | the-Answer-to-the-Ultimate-Question 32 | testsuites/parser:25 33 | PARSE_SUCCESS 1 1 34 | 0 35 | 0 36 | testsuites/parser:28 37 | PARSE_SUCCESS 1 1 38 | 1234 39 | 1234 40 | testsuites/parser:31 41 | PARSE_SUCCESS 1 1 42 | 3.5 43 | 3.5 44 | testsuites/parser:34 45 | PARSE_SUCCESS 1 1 46 | +732 47 | 732 48 | testsuites/parser:37 49 | PARSE_SUCCESS 1 1 50 | -42 51 | -42 52 | testsuites/parser:40 53 | PARSE_SUCCESS 1 1 54 | 13e2 55 | 1300 56 | testsuites/parser:43 57 | PARSE_SUCCESS 1 1 58 | 9e+1 59 | 90 60 | testsuites/parser:46 61 | PARSE_SUCCESS 1 1 62 | 125e-1 63 | 12.5 64 | testsuites/parser:49 65 | PARSE_SUCCESS 1 1 66 | "foo" 67 | "foo" 68 | testsuites/parser:52 69 | PARSE_SUCCESS 1 1 70 | "Hello, World!" 71 | "Hello, World!" 72 | testsuites/parser:55 73 | PARSE_SUCCESS 1 1 74 | "( ) . 0 a" 75 | "( ) . 0 a" 76 | testsuites/parser:58 77 | PARSE_SUCCESS 1 1 78 | "foo\nbar" 79 | "foo\nbar" 80 | testsuites/parser:61 81 | PARSE_SUCCESS 2 1 82 | "foo 83 | bar" 84 | "foo\nbar" 85 | testsuites/parser:65 86 | PARSE_SUCCESS 1 1 87 | "A \" B" 88 | "A \" B" 89 | testsuites/parser:68 90 | PARSE_SUCCESS 1 1 91 | "A\t B" 92 | "A\t\tB" 93 | testsuites/parser:71 94 | PARSE_SUCCESS 1 1 95 | "\\\\" 96 | "\\\\" 97 | testsuites/parser:74 98 | PARSE_FAILURE 1 99 | "hello 100 | testsuites/parser:77 101 | PARSE_FAILURE 1 102 | "world\ 103 | testsuites/parser:80 104 | PARSE_FAILURE 1 105 | "unknown \p escape sequence" 106 | testsuites/parser:83 107 | PARSE_SUCCESS 1 1 108 | () 109 | () 110 | testsuites/parser:86 111 | PARSE_SUCCESS 1 1 112 | [] 113 | () 114 | testsuites/parser:89 115 | PARSE_SUCCESS 1 1 116 | (12) 117 | (12) 118 | testsuites/parser:92 119 | PARSE_FAILURE 1 120 | (12 .) 121 | testsuites/parser:95 122 | PARSE_FAILURE 1 123 | (. 34) 124 | testsuites/parser:98 125 | PARSE_SUCCESS 1 1 126 | (foo . bar) 127 | (foo . bar) 128 | testsuites/parser:101 129 | PARSE_SUCCESS 1 1 130 | (1 2 . 3) 131 | (1 2 . 3) 132 | testsuites/parser:104 133 | PARSE_SUCCESS 1 1 134 | (a b c d) 135 | (a b c d) 136 | testsuites/parser:107 137 | PARSE_SUCCESS 1 1 138 | (foo [bar (baz)]) 139 | (foo (bar (baz))) 140 | testsuites/parser:110 141 | PARSE_SUCCESS 1 1 142 | (#t #f) 143 | (#t #f) 144 | testsuites/parser:113 145 | PARSE_SUCCESS 1 1 146 | 'foo 147 | 'foo 148 | testsuites/parser:116 149 | PARSE_SUCCESS 1 1 150 | '(foo 123) 151 | '(foo 123) 152 | testsuites/parser:119 153 | PARSE_SUCCESS 1 1 154 | `(i ,j ,@(k l)) 155 | `(i ,j ,@(k l)) 156 | testsuites/parser:122 157 | PARSE_SUCCESS 1 1 158 | 123 159 | 123 160 | testsuites/parser:125 161 | PARSE_SUCCESS 3 1 162 | ; hello 163 | ; world 164 | () 165 | () 166 | testsuites/parser:130 167 | PARSE_SUCCESS 2 1 168 | (foo ; comment 169 | bar) ; comment 170 | (foo bar) 171 | testsuites/parser:134 172 | PARSE_SUCCESS 4 1 173 | (this 174 | is 175 | the 176 | last) 177 | (this is the last) 178 | testsuites/compiler:1 179 | COMPILE_SUCCESS 1 2 180 | 123 181 | [0 entry] 182 | ldc 123 183 | testsuites/compiler:5 184 | COMPILE_SUCCESS 1 2 185 | "foo" 186 | [0 entry] 187 | ldc "foo" 188 | testsuites/compiler:9 189 | COMPILE_SUCCESS 1 2 190 | foo 191 | [0 entry] 192 | ldv foo 193 | testsuites/compiler:13 194 | COMPILE_SUCCESS 1 3 195 | (foo) 196 | [0 entry] 197 | ldv foo 198 | app 0 199 | testsuites/compiler:18 200 | COMPILE_SUCCESS 1 5 201 | (foo bar baz) 202 | [0 entry] 203 | ldv foo 204 | ldv bar 205 | ldv baz 206 | app 2 207 | testsuites/compiler:25 208 | COMPILE_SUCCESS 1 8 209 | (foo (bar (baz)) hoge) 210 | [0 entry] 211 | ldv foo 212 | ldv bar 213 | ldv baz 214 | app 0 215 | app 1 216 | ldv hoge 217 | app 2 218 | testsuites/compiler:35 219 | COMPILE_FAILURE 1 220 | (foo . bar) 221 | testsuites/compiler:38 222 | COMPILE_FAILURE 1 223 | (a b c . d) 224 | testsuites/compiler:41 225 | COMPILE_SUCCESS 1 2 226 | (begin) 227 | [0 entry] 228 | ldc () 229 | testsuites/compiler:45 230 | COMPILE_SUCCESS 1 2 231 | (begin x) 232 | [0 entry] 233 | ldv x 234 | testsuites/compiler:49 235 | COMPILE_SUCCESS 1 4 236 | (begin x y) 237 | [0 entry] 238 | ldv x 239 | pop 240 | ldv y 241 | testsuites/compiler:55 242 | COMPILE_SUCCESS 1 8 243 | (begin a (b c) d) 244 | [0 entry] 245 | ldv a 246 | pop 247 | ldv b 248 | ldv c 249 | app 1 250 | pop 251 | ldv d 252 | testsuites/compiler:65 253 | COMPILE_SUCCESS 1 4 254 | (def hello 123) 255 | [0 entry] 256 | ldc 123 257 | def hello 258 | ldc () 259 | testsuites/compiler:71 260 | COMPILE_SUCCESS 1 6 261 | (def hello (a b)) 262 | [0 entry] 263 | ldv a 264 | ldv b 265 | app 1 266 | def hello 267 | ldc () 268 | testsuites/compiler:79 269 | COMPILE_SUCCESS 1 6 270 | (set! goodbye (c d)) 271 | [0 entry] 272 | ldv c 273 | ldv d 274 | app 1 275 | set goodbye 276 | ldc () 277 | testsuites/compiler:87 278 | COMPILE_FAILURE 1 279 | (def hello) 280 | testsuites/compiler:90 281 | COMPILE_FAILURE 1 282 | (def (foo bar) 123) 283 | testsuites/compiler:93 284 | COMPILE_FAILURE 1 285 | (def "string" 42) 286 | testsuites/compiler:96 287 | COMPILE_SUCCESS 1 9 288 | (if a b c) 289 | [0 entry] 290 | ldv a 291 | sel [1 then] [2 else] 292 | [1 then] 293 | ldv b 294 | leave 295 | [2 else] 296 | ldv c 297 | leave 298 | testsuites/compiler:107 299 | COMPILE_FAILURE 1 300 | (if a b) 301 | testsuites/compiler:110 302 | COMPILE_SUCCESS 1 13 303 | (if (a b) (x y) z) 304 | [0 entry] 305 | ldv a 306 | ldv b 307 | app 1 308 | sel [1 then] [2 else] 309 | [1 then] 310 | ldv x 311 | ldv y 312 | app 1 313 | leave 314 | [2 else] 315 | ldv z 316 | leave 317 | testsuites/compiler:125 318 | COMPILE_SUCCESS 1 30 319 | (if (if a b c) (if d e f) (if g h i)) 320 | [0 entry] 321 | ldv a 322 | sel [1 then] [2 else] 323 | sel [3 then] [6 else] 324 | [1 then] 325 | ldv b 326 | leave 327 | [2 else] 328 | ldv c 329 | leave 330 | [3 then] 331 | ldv d 332 | sel [4 then] [5 else] 333 | leave 334 | [4 then] 335 | ldv e 336 | leave 337 | [5 else] 338 | ldv f 339 | leave 340 | [6 else] 341 | ldv g 342 | sel [7 then] [8 else] 343 | leave 344 | [7 then] 345 | ldv h 346 | leave 347 | [8 else] 348 | ldv i 349 | leave 350 | testsuites/compiler:157 351 | COMPILE_FAILURE 1 352 | (if a b c d) 353 | testsuites/compiler:160 354 | COMPILE_SUCCESS 1 5 355 | (fun ()) 356 | [0 entry] 357 | ldf [1 fun ()] 358 | [1 fun ()] 359 | ldc () 360 | leave 361 | testsuites/compiler:167 362 | COMPILE_SUCCESS 1 7 363 | (fun () 12 34) 364 | [0 entry] 365 | ldf [1 fun ()] 366 | [1 fun ()] 367 | ldc 12 368 | pop 369 | ldc 34 370 | leave 371 | testsuites/compiler:176 372 | COMPILE_FAILURE 1 373 | (fun "x") 374 | testsuites/compiler:179 375 | COMPILE_SUCCESS 1 5 376 | (fun abc) 377 | [0 entry] 378 | ldf [1 fun abc] 379 | [1 fun abc] 380 | ldc () 381 | leave 382 | testsuites/compiler:186 383 | COMPILE_SUCCESS 1 5 384 | (fun (a b . c)) 385 | [0 entry] 386 | ldf [1 fun (a b . c)] 387 | [1 fun (a b . c)] 388 | ldc () 389 | leave 390 | testsuites/compiler:193 391 | COMPILE_SUCCESS 1 5 392 | (fun (x y) z) 393 | [0 entry] 394 | ldf [1 fun (x y)] 395 | [1 fun (x y)] 396 | ldv z 397 | leave 398 | testsuites/compiler:200 399 | COMPILE_FAILURE 1 400 | (fun (0)) 401 | testsuites/compiler:203 402 | COMPILE_SUCCESS 1 4 403 | (macro ()) 404 | [0 entry] 405 | ldm [1 macro ()] 406 | [1 macro ()] 407 | ldc () 408 | testsuites/compiler:209 409 | COMPILE_SUCCESS 1 4 410 | (macro (x y) x) 411 | [0 entry] 412 | ldm [1 macro (x y)] 413 | [1 macro (x y)] 414 | ldv x 415 | testsuites/compiler:215 416 | COMPILE_SUCCESS 1 2 417 | (builtin hello) 418 | [0 entry] 419 | ldb hello 420 | testsuites/compiler:219 421 | COMPILE_FAILURE 1 422 | (builtin "hello") 423 | testsuites/compiler:222 424 | COMPILE_SUCCESS 1 2 425 | '(1 2 3) 426 | [0 entry] 427 | ldc (1 2 3) 428 | testsuites/compiler:226 429 | COMPILE_FAILURE 1 430 | (quote a b) 431 | testsuites/vm:1 432 | EVAL_SUCCESS 1 1 433 | 123 434 | 123 435 | testsuites/vm:4 436 | EVAL_SUCCESS 1 1 437 | 'hoge 438 | hoge 439 | testsuites/vm:7 440 | EVAL_SUCCESS 1 1 441 | (begin 123 456 789) 442 | 789 443 | testsuites/vm:10 444 | EVAL_FAILURE 1 445 | foo 446 | testsuites/vm:13 447 | EVAL_SUCCESS 1 1 448 | (def foo "foo") 449 | () 450 | testsuites/vm:16 451 | EVAL_SUCCESS 1 1 452 | foo 453 | "foo" 454 | testsuites/vm:19 455 | EVAL_SUCCESS 1 1 456 | (def foo "bar") 457 | () 458 | testsuites/vm:22 459 | EVAL_SUCCESS 1 1 460 | foo 461 | "bar" 462 | testsuites/vm:25 463 | EVAL_SUCCESS 1 1 464 | (set! foo "baz") 465 | () 466 | testsuites/vm:28 467 | EVAL_SUCCESS 1 1 468 | foo 469 | "baz" 470 | testsuites/vm:31 471 | EVAL_FAILURE 1 472 | (set! hoge "fuga") 473 | testsuites/vm:34 474 | EVAL_SUCCESS 1 1 475 | (fun () 123) 476 | 477 | testsuites/vm:37 478 | EVAL_SUCCESS 1 1 479 | ((fun () 123)) 480 | 123 481 | testsuites/vm:40 482 | EVAL_FAILURE 1 483 | ((fun (a b) a) 12) 484 | testsuites/vm:43 485 | EVAL_SUCCESS 1 1 486 | ((fun (a b) a) 12 34) 487 | 12 488 | testsuites/vm:46 489 | EVAL_FAILURE 1 490 | ((fun (a b) a) 12 34 56) 491 | testsuites/vm:49 492 | EVAL_FAILURE 1 493 | ((fun (a . b) b)) 494 | testsuites/vm:52 495 | EVAL_SUCCESS 1 1 496 | ((fun (a . b) a) 12) 497 | 12 498 | testsuites/vm:55 499 | EVAL_SUCCESS 1 1 500 | ((fun (a . b) b) 12) 501 | () 502 | testsuites/vm:58 503 | EVAL_SUCCESS 1 1 504 | ((fun (a . b) b) 12 34 56) 505 | (34 56) 506 | testsuites/vm:61 507 | EVAL_SUCCESS 1 1 508 | ((fun a a) 12 34) 509 | (12 34) 510 | testsuites/vm:64 511 | EVAL_SUCCESS 1 1 512 | (set! foo #t) 513 | () 514 | testsuites/vm:66 515 | EVAL_SUCCESS 1 1 516 | ((fun () (def foo #f))) 517 | () 518 | testsuites/vm:68 519 | EVAL_SUCCESS 1 1 520 | foo 521 | #t 522 | testsuites/vm:71 523 | EVAL_SUCCESS 1 1 524 | ((fun () (set! foo #f))) 525 | () 526 | testsuites/vm:73 527 | EVAL_SUCCESS 1 1 528 | foo 529 | #f 530 | testsuites/vm:76 531 | EVAL_SUCCESS 1 1 532 | (def _list (fun a a)) 533 | () 534 | testsuites/vm:78 535 | EVAL_SUCCESS 1 1 536 | (_list 1 (_list 2 3) 4) 537 | (1 (2 3) 4) 538 | testsuites/vm:81 539 | EVAL_SUCCESS 1 1 540 | (set! foo 0) 541 | () 542 | testsuites/vm:83 543 | EVAL_SUCCESS 1 1 544 | (set! foo (_list foo 1)) 545 | () 546 | testsuites/vm:85 547 | EVAL_SUCCESS 1 1 548 | foo 549 | (0 1) 550 | testsuites/vm:88 551 | EVAL_SUCCESS 6 1 552 | (begin 553 | (set! foo 0) 554 | (set! foo (_list foo 1)) 555 | (set! foo (_list foo 2)) 556 | (set! foo (_list foo 3)) 557 | foo) 558 | (((0 1) 2) 3) 559 | testsuites/vm:96 560 | EVAL_SUCCESS 1 1 561 | (if #t 123 456) 562 | 123 563 | testsuites/vm:99 564 | EVAL_SUCCESS 1 1 565 | (if #f 123 456) 566 | 456 567 | testsuites/vm:102 568 | EVAL_SUCCESS 1 1 569 | (if "anything except #f" 123 456) 570 | 123 571 | testsuites/vm:105 572 | EVAL_SUCCESS 1 1 573 | (if () 123 456) 574 | 123 575 | testsuites/vm:108 576 | EVAL_SUCCESS 1 1 577 | (if #t (def hoge "fuga") (def hoge "fuga")) 578 | () 579 | testsuites/vm:110 580 | EVAL_FAILURE 1 581 | hoge 582 | testsuites/vm:113 583 | EVAL_SUCCESS 6 1 584 | (begin 585 | (set! foo 0) 586 | (if #t 587 | (set! foo (_list foo 1)) 588 | (set! foo (_list foo 2))) 589 | foo) 590 | (0 1) 591 | testsuites/vm:121 592 | EVAL_SUCCESS 6 1 593 | (begin 594 | (set! foo 0) 595 | (if #f 596 | (set! foo (_list foo 1)) 597 | (set! foo (_list foo 2))) 598 | foo) 599 | (0 2) 600 | testsuites/vm:129 601 | EVAL_SUCCESS 1 1 602 | (macro (a b) a) 603 | 604 | testsuites/vm:132 605 | EVAL_FAILURE 1 606 | ((macro (a b) a) 12 34) 607 | testsuites/vm:135 608 | EVAL_SUCCESS 1 1 609 | (def _skip (macro (a . b) b)) 610 | () 611 | testsuites/vm:137 612 | EVAL_SUCCESS 1 1 613 | (_skip 12 _list 34 56) 614 | (34 56) 615 | testsuites/vm:140 616 | EVAL_SUCCESS 1 1 617 | (set! foo #t) 618 | () 619 | testsuites/vm:142 620 | EVAL_SUCCESS 1 1 621 | (_skip (set! foo #f) _list) 622 | () 623 | testsuites/vm:144 624 | EVAL_SUCCESS 1 1 625 | foo 626 | #t 627 | testsuites/vm:147 628 | EVAL_SUCCESS 1 1 629 | (_skip 12 _skip 34 _list 56 78) 630 | (56 78) 631 | testsuites/vm:150 632 | EVAL_SUCCESS 1 1 633 | (_list 12 (_skip 34 _list 56 78)) 634 | (12 (56 78)) 635 | boot.lisp:1 636 | EVAL_ALL 1 637 | (def cons (builtin cons)) 638 | boot.lisp:2 639 | EVAL_FAILURE 1 640 | (cons 1) 641 | boot.lisp:4 642 | EVAL_SUCCESS 1 1 643 | (cons 1 2) 644 | (1 . 2) 645 | boot.lisp:6 646 | EVAL_FAILURE 1 647 | (cons 1 2 3) 648 | boot.lisp:8 649 | EVAL_ALL 6 650 | 651 | (def list (fun xs xs)) 652 | 653 | (def defun (macro (sym . body) (list 'def sym (cons 'fun body)))) 654 | (def defmacro (macro (sym . body) (list 'def sym (cons 'macro body)))) 655 | (def defbuiltin (macro (sym . intf) (list 'def sym (list 'builtin sym)))) 656 | boot.lisp:14 657 | EVAL_SUCCESS 1 1 658 | (defun _f (a b) b) 659 | () 660 | boot.lisp:16 661 | EVAL_SUCCESS 1 1 662 | (_f 3 5) 663 | 5 664 | boot.lisp:18 665 | EVAL_SUCCESS 1 1 666 | (defmacro _m (a . b) b) 667 | () 668 | boot.lisp:20 669 | EVAL_SUCCESS 1 1 670 | (_m 1 _f 2 3) 671 | 3 672 | boot.lisp:22 673 | EVAL_ALL 8 674 | 675 | (defbuiltin exit (exitcode)) 676 | (defbuiltin error (msg)) 677 | 678 | (defbuiltin gensym ()) 679 | 680 | (defbuiltin car (cons)) 681 | (defbuiltin cdr (cons)) 682 | boot.lisp:30 683 | EVAL_SUCCESS 1 1 684 | (car (cons 12 34)) 685 | 12 686 | boot.lisp:32 687 | EVAL_SUCCESS 1 1 688 | (cdr (cons 12 34)) 689 | 34 690 | boot.lisp:34 691 | EVAL_ALL 2 692 | 693 | (defbuiltin apply (f args)) 694 | boot.lisp:36 695 | EVAL_SUCCESS 1 1 696 | (apply cons (list 12 34)) 697 | (12 . 34) 698 | boot.lisp:38 699 | EVAL_ALL 3 700 | 701 | (defun id (a) 702 | a) 703 | boot.lisp:41 704 | EVAL_SUCCESS 1 1 705 | (id 0) 706 | 0 707 | boot.lisp:43 708 | EVAL_SUCCESS 1 1 709 | (id "foo") 710 | "foo" 711 | boot.lisp:45 712 | EVAL_ALL 3 713 | 714 | (defun compose (f g) 715 | (fun (x) (f (g x)))) 716 | boot.lisp:48 717 | EVAL_SUCCESS 1 1 718 | ((compose car cdr) (list 12 34 56)) 719 | 34 720 | boot.lisp:50 721 | EVAL_ALL 3 722 | 723 | (defun flip (f) 724 | (fun (a b) (f b a))) 725 | boot.lisp:53 726 | EVAL_SUCCESS 1 1 727 | ((flip (fun (a b) a)) 12 34) 728 | 34 729 | boot.lisp:55 730 | EVAL_ALL 3 731 | 732 | (defun const (v) 733 | (fun _ v)) 734 | boot.lisp:58 735 | EVAL_SUCCESS 1 1 736 | ((const 123)) 737 | 123 738 | boot.lisp:60 739 | EVAL_SUCCESS 1 1 740 | ((const 123) 456 789) 741 | 123 742 | boot.lisp:62 743 | EVAL_ALL 23 744 | 745 | (def caar (compose car car)) 746 | (def cadr (compose car cdr)) 747 | (def cdar (compose cdr car)) 748 | (def cddr (compose cdr cdr)) 749 | (def caaar (compose car caar)) 750 | (def cdaar (compose cdr caar)) 751 | (def cadar (compose car cdar)) 752 | (def cddar (compose cdr cdar)) 753 | (def caadr (compose car cadr)) 754 | (def cdadr (compose cdr cadr)) 755 | (def caddr (compose car cddr)) 756 | (def cdddr (compose cdr cddr)) 757 | 758 | (defbuiltin num? (x)) 759 | (defbuiltin sym? (x)) 760 | (defbuiltin str? (x)) 761 | (defbuiltin cons? (x)) 762 | (defbuiltin nil? (x)) 763 | (defbuiltin bool? (x)) 764 | (defbuiltin proc? (x)) 765 | (defbuiltin meta? (x)) 766 | (defbuiltin vec? (x)) 767 | boot.lisp:85 768 | EVAL_SUCCESS 1 1 769 | (num? 123) 770 | #t 771 | boot.lisp:87 772 | EVAL_FAILURE 1 773 | (num? 12 34) 774 | boot.lisp:89 775 | EVAL_SUCCESS 1 1 776 | (num? "foo") 777 | #f 778 | boot.lisp:91 779 | EVAL_SUCCESS 1 1 780 | (sym? 'foo) 781 | #t 782 | boot.lisp:93 783 | EVAL_SUCCESS 1 1 784 | (str? "foo") 785 | #t 786 | boot.lisp:95 787 | EVAL_SUCCESS 1 1 788 | (cons? (list 1 2 3)) 789 | #t 790 | boot.lisp:97 791 | EVAL_SUCCESS 1 1 792 | (nil? ()) 793 | #t 794 | boot.lisp:99 795 | EVAL_SUCCESS 1 1 796 | (list (bool? #t) (bool? ())) 797 | (#t #f) 798 | boot.lisp:101 799 | EVAL_SUCCESS 1 1 800 | (list (proc? (fun ())) (proc? cons) (proc? (macro ())) (proc? def)) 801 | (#t #t #f #f) 802 | boot.lisp:103 803 | EVAL_SUCCESS 1 1 804 | (list (meta? (fun ())) (meta? cons) (meta? (macro ())) (meta? def)) 805 | (#f #f #t #t) 806 | boot.lisp:105 807 | EVAL_SUCCESS 1 1 808 | (list (vec? 123)) 809 | (#f) 810 | boot.lisp:107 811 | EVAL_ALL 7 812 | 813 | (defun list? (x) 814 | (if (nil? x) 815 | #t 816 | (if (cons? x) 817 | (list? (cdr x)) 818 | #f))) 819 | boot.lisp:114 820 | EVAL_SUCCESS 1 1 821 | (list? ()) 822 | #t 823 | boot.lisp:116 824 | EVAL_SUCCESS 1 1 825 | (list? '(12 . 34)) 826 | #f 827 | boot.lisp:118 828 | EVAL_SUCCESS 1 1 829 | (list? '(12 34 . 56)) 830 | #f 831 | boot.lisp:120 832 | EVAL_SUCCESS 1 1 833 | (list? '(12 34 56)) 834 | #t 835 | boot.lisp:122 836 | EVAL_ALL 6 837 | 838 | (defbuiltin + nums) 839 | (defbuiltin - (num . nums)) 840 | (defbuiltin * nums) 841 | (defbuiltin / (num . nums)) 842 | (defbuiltin % (num . nums)) 843 | boot.lisp:128 844 | EVAL_SUCCESS 1 1 845 | (list (+) (+ 11) (+ 3 4 5)) 846 | (0 11 12) 847 | boot.lisp:130 848 | EVAL_SUCCESS 1 1 849 | (list (- 5) (- 5 2)) 850 | (-5 3) 851 | boot.lisp:132 852 | EVAL_SUCCESS 1 1 853 | (list (*) (* 11) (* 3 4 5)) 854 | (1 11 60) 855 | boot.lisp:134 856 | EVAL_SUCCESS 1 1 857 | (list (/ 2) (/ 20 5 2)) 858 | (0.5 2) 859 | boot.lisp:136 860 | EVAL_SUCCESS 1 1 861 | (list (% 5) (% 5 3)) 862 | (5 2) 863 | boot.lisp:138 864 | EVAL_ALL 2 865 | 866 | (defbuiltin = xs) 867 | boot.lisp:140 868 | EVAL_SUCCESS 1 1 869 | (list (=) (= 1) (= 1 1) (= 1 2) (= 1 1 1) (= 1 1 2)) 870 | (#t #t #t #f #t #f) 871 | boot.lisp:142 872 | EVAL_SUCCESS 1 1 873 | (list (= "foo" "foo") (= "foo" "bar")) 874 | (#t #f) 875 | boot.lisp:144 876 | EVAL_SUCCESS 1 1 877 | (list (= #t #t) (= #f #f) (= #t #f)) 878 | (#t #t #f) 879 | boot.lisp:146 880 | EVAL_SUCCESS 1 1 881 | (list (= () ()) (= '(1 2) '(1 2)) (= '(1 2) '(1 3)) (= '(1 2 . 3) '(1 2 . 3)) (= '(1 2 3) '(1 2 . 3))) 882 | (#t #t #f #t #f) 883 | boot.lisp:148 884 | EVAL_SUCCESS 1 1 885 | (= (fun ()) (fun ())) 886 | #f 887 | boot.lisp:150 888 | EVAL_SUCCESS 1 1 889 | (list (= 123 "123") (= "foo" 'foo)) 890 | (#f #f) 891 | boot.lisp:152 892 | EVAL_ALL 5 893 | 894 | (defbuiltin < nums-or-strs) 895 | (defbuiltin > nums-or-strs) 896 | (defbuiltin <= nums-or-strs) 897 | (defbuiltin >= nums-or-strs) 898 | boot.lisp:157 899 | EVAL_SUCCESS 1 1 900 | (list (<) (< 1) (< 1 2) (< 1 2 3) (< 1 3 3) (< 1 4 3) (< 4 3) (< 4 4 3)) 901 | (#t #t #t #t #f #f #f #f) 902 | boot.lisp:159 903 | EVAL_SUCCESS 1 1 904 | (list (>) (> 1) (> 1 2) (> 1 2 3) (> 1 3 3) (> 1 4 3) (> 4 3) (> 4 4 3)) 905 | (#t #t #f #f #f #f #t #f) 906 | boot.lisp:161 907 | EVAL_SUCCESS 1 1 908 | (list (<=) (<= 1) (<= 1 2) (<= 1 2 3) (<= 1 3 3) (<= 1 4 3) (<= 4 3) (<= 4 4 3)) 909 | (#t #t #t #t #t #f #f #f) 910 | boot.lisp:163 911 | EVAL_SUCCESS 1 1 912 | (list (>=) (>= 1) (>= 1 2) (>= 1 2 3) (>= 1 3 3) (>= 1 4 3) (>= 4 3) (>= 4 4 3)) 913 | (#t #t #f #f #f #f #t #t) 914 | boot.lisp:165 915 | EVAL_SUCCESS 1 1 916 | (list (< "abc" "cab") (< "abc" "abd") (< "bac" "acb")) 917 | (#t #t #f) 918 | boot.lisp:167 919 | EVAL_FAILURE 1 920 | (< 123 "456") 921 | boot.lisp:169 922 | EVAL_FAILURE 1 923 | (< #f) 924 | boot.lisp:171 925 | EVAL_ALL 5 926 | 927 | (defun map (f xs) 928 | (if (nil? xs) 929 | () 930 | (cons (f (car xs)) (map f (cdr xs))))) 931 | boot.lisp:176 932 | EVAL_SUCCESS 1 1 933 | (map (fun (a) (* a 3)) (list 1 2 5 4)) 934 | (3 6 15 12) 935 | boot.lisp:178 936 | EVAL_ALL 7 937 | 938 | (defun filter (f xs) 939 | (if (nil? xs) 940 | () 941 | (if (f (car xs)) 942 | (cons (car xs) (filter f (cdr xs))) 943 | (filter f (cdr xs))))) 944 | boot.lisp:185 945 | EVAL_SUCCESS 1 1 946 | (filter num? (list 1 2 "foo" 3 'bar 4)) 947 | (1 2 3 4) 948 | boot.lisp:187 949 | EVAL_ALL 2 950 | 951 | (def for (flip map)) 952 | boot.lisp:189 953 | EVAL_SUCCESS 1 1 954 | (for (list 1 2 3) (fun (a) (* a a))) 955 | (1 4 9) 956 | boot.lisp:191 957 | EVAL_ALL 5 958 | 959 | (defun foldl (f i xs) 960 | (if (nil? xs) 961 | i 962 | (foldl f (f i (car xs)) (cdr xs)))) 963 | boot.lisp:196 964 | EVAL_SUCCESS 1 1 965 | (foldl cons () (list 2 5 3)) 966 | (((() . 2) . 5) . 3) 967 | boot.lisp:198 968 | EVAL_ALL 5 969 | 970 | (defun foldr (f i xs) 971 | (if (nil? xs) 972 | i 973 | (f (car xs) (foldr f i (cdr xs))))) 974 | boot.lisp:203 975 | EVAL_SUCCESS 1 1 976 | (foldr cons () (list 2 5 3)) 977 | (2 5 3) 978 | boot.lisp:205 979 | EVAL_ALL 8 980 | 981 | (defun append ls 982 | (foldr *append () ls)) 983 | 984 | (defun *append (a b) 985 | (if (nil? a) 986 | b 987 | (cons (car a) (*append (cdr a) b)))) 988 | boot.lisp:213 989 | EVAL_SUCCESS 1 1 990 | (append (list 1 2 3) (list 4 5 6) (list 7 8)) 991 | (1 2 3 4 5 6 7 8) 992 | boot.lisp:215 993 | EVAL_ALL 3 994 | 995 | (defun reverse (ls) 996 | (foldl (flip cons) () ls)) 997 | boot.lisp:218 998 | EVAL_SUCCESS 1 1 999 | (reverse (list 1 2 4 5)) 1000 | (5 4 2 1) 1001 | boot.lisp:220 1002 | EVAL_ALL 5 1003 | 1004 | (defun nth (n xs) 1005 | (if (= n 0) 1006 | (car xs) 1007 | (nth (- n 1) (cdr xs)))) 1008 | boot.lisp:225 1009 | EVAL_SUCCESS 1 1 1010 | (nth 3 (list 9 8 7 6 5)) 1011 | 6 1012 | boot.lisp:227 1013 | EVAL_ALL 5 1014 | 1015 | (defun iota (a b) 1016 | (if (< a b) 1017 | (cons a (iota (+ a 1) b)) 1018 | '())) 1019 | boot.lisp:232 1020 | EVAL_SUCCESS 1 1 1021 | (iota 0 5) 1022 | (0 1 2 3 4) 1023 | boot.lisp:234 1024 | EVAL_SUCCESS 1 1 1025 | (iota 2 4) 1026 | (2 3) 1027 | boot.lisp:236 1028 | EVAL_SUCCESS 1 1 1029 | (iota 3 3) 1030 | () 1031 | boot.lisp:238 1032 | EVAL_ALL 3 1033 | 1034 | (defun not (x) 1035 | (if x #f #t)) 1036 | boot.lisp:241 1037 | EVAL_SUCCESS 1 1 1038 | (map not (list 123 () #t #f)) 1039 | (#f #f #f #t) 1040 | boot.lisp:243 1041 | EVAL_ALL 9 1042 | 1043 | (def else #t) 1044 | 1045 | (defmacro cond preds 1046 | (if (nil? preds) 1047 | () 1048 | (list 'if (caar preds) 1049 | (cons 'begin (cdar preds)) 1050 | (cons 'cond (cdr preds))))) 1051 | boot.lisp:252 1052 | EVAL_SUCCESS 1 1 1053 | (cond) 1054 | () 1055 | boot.lisp:254 1056 | EVAL_SUCCESS 1 1 1057 | (cond [#t 123]) 1058 | 123 1059 | boot.lisp:256 1060 | EVAL_SUCCESS 1 1 1061 | (cond [#t 123 456]) 1062 | 456 1063 | boot.lisp:258 1064 | EVAL_SUCCESS 1 1 1065 | (cond [#t 1] [#t 2] [#t 3]) 1066 | 1 1067 | boot.lisp:260 1068 | EVAL_SUCCESS 1 1 1069 | (cond [#f 1] [#t 2] [#t 3]) 1070 | 2 1071 | boot.lisp:262 1072 | EVAL_SUCCESS 1 1 1073 | (cond [#f 1] [#f 2] [#t 3]) 1074 | 3 1075 | boot.lisp:264 1076 | EVAL_SUCCESS 1 1 1077 | (cond [#f 1] [#f 2] [#f 3]) 1078 | () 1079 | boot.lisp:266 1080 | EVAL_SUCCESS 1 1 1081 | (def _r ()) 1082 | () 1083 | boot.lisp:268 1084 | EVAL_SUCCESS 4 1 1085 | (cond 1086 | [(begin (set! _r (cons 1 _r)) #f) (set! _r (cons 2 _r))] 1087 | [(begin (set! _r (cons 3 _r)) #t) (set! _r (cons 4 _r))] 1088 | [(begin (set! _r (cons 5 _r)) #t) (set! _r (cons 6 _r))]) 1089 | () 1090 | boot.lisp:273 1091 | EVAL_SUCCESS 1 1 1092 | _r 1093 | (4 3 1) 1094 | boot.lisp:275 1095 | EVAL_ALL 10 1096 | 1097 | (defmacro and values 1098 | (cond 1099 | [(nil? values) #t] 1100 | [(nil? (cdr values)) (car values)] 1101 | [else ((fun (tmp) 1102 | (list (list 'fun (list tmp) 1103 | (list 'if tmp (cons 'and (cdr values)) tmp)) 1104 | (car values))) 1105 | (gensym))])) 1106 | boot.lisp:285 1107 | EVAL_SUCCESS 1 1 1108 | (and) 1109 | #t 1110 | boot.lisp:287 1111 | EVAL_SUCCESS 1 1 1112 | (and 123) 1113 | 123 1114 | boot.lisp:289 1115 | EVAL_SUCCESS 1 1 1116 | (and 123 456) 1117 | 456 1118 | boot.lisp:291 1119 | EVAL_SUCCESS 1 1 1120 | (and #f 456) 1121 | #f 1122 | boot.lisp:293 1123 | EVAL_SUCCESS 1 1 1124 | (and 123 456 789) 1125 | 789 1126 | boot.lisp:295 1127 | EVAL_SUCCESS 1 1 1128 | (def _r ()) 1129 | () 1130 | boot.lisp:297 1131 | EVAL_SUCCESS 5 1 1132 | (and 1133 | (begin (set! _r (cons 1 _r)) 123) 1134 | (begin (set! _r (cons 2 _r)) 456) 1135 | (begin (set! _r (cons 3 _r)) #f) 1136 | (begin (set! _r (cons 4 _r)) 789)) 1137 | #f 1138 | boot.lisp:303 1139 | EVAL_SUCCESS 1 1 1140 | _r 1141 | (3 2 1) 1142 | boot.lisp:305 1143 | EVAL_ALL 10 1144 | 1145 | (defmacro or values 1146 | (cond 1147 | [(nil? values) #f] 1148 | [(nil? (cdr values)) (car values)] 1149 | [else ((fun (tmp) 1150 | (list (list 'fun (list tmp) 1151 | (list 'if tmp tmp (cons 'or (cdr values)))) 1152 | (car values))) 1153 | (gensym))])) 1154 | boot.lisp:315 1155 | EVAL_SUCCESS 1 1 1156 | (or) 1157 | #f 1158 | boot.lisp:317 1159 | EVAL_SUCCESS 1 1 1160 | (or 123) 1161 | 123 1162 | boot.lisp:319 1163 | EVAL_SUCCESS 1 1 1164 | (or 123 456) 1165 | 123 1166 | boot.lisp:321 1167 | EVAL_SUCCESS 1 1 1168 | (or #f 456) 1169 | 456 1170 | boot.lisp:323 1171 | EVAL_SUCCESS 1 1 1172 | (or 123 456 789) 1173 | 123 1174 | boot.lisp:325 1175 | EVAL_SUCCESS 1 1 1176 | (def _r ()) 1177 | () 1178 | boot.lisp:327 1179 | EVAL_SUCCESS 5 1 1180 | (or 1181 | (begin (set! _r (cons 1 _r)) #f) 1182 | (begin (set! _r (cons 2 _r)) #f) 1183 | (begin (set! _r (cons 3 _r)) 123) 1184 | (begin (set! _r (cons 4 _r)) 456)) 1185 | 123 1186 | boot.lisp:333 1187 | EVAL_SUCCESS 1 1 1188 | _r 1189 | (3 2 1) 1190 | boot.lisp:335 1191 | EVAL_ALL 6 1192 | 1193 | (defun all (f xs) 1194 | (if (nil? xs) 1195 | #t 1196 | (and (f (car xs)) 1197 | (all f (cdr xs))))) 1198 | boot.lisp:341 1199 | EVAL_SUCCESS 1 1 1200 | (all num? (list)) 1201 | #t 1202 | boot.lisp:343 1203 | EVAL_SUCCESS 1 1 1204 | (all num? (list 1 2 3)) 1205 | #t 1206 | boot.lisp:345 1207 | EVAL_SUCCESS 1 1 1208 | (all num? (list 1 "2" 3)) 1209 | #f 1210 | boot.lisp:347 1211 | EVAL_ALL 6 1212 | 1213 | (defun any (f xs) 1214 | (if (nil? xs) 1215 | #f 1216 | (or (f (car xs)) 1217 | (any f (cdr xs))))) 1218 | boot.lisp:353 1219 | EVAL_SUCCESS 1 1 1220 | (any num? (list)) 1221 | #f 1222 | boot.lisp:355 1223 | EVAL_SUCCESS 1 1 1224 | (any num? (list 1 2 3)) 1225 | #t 1226 | boot.lisp:357 1227 | EVAL_SUCCESS 1 1 1228 | (any num? (list "1" 2 "3")) 1229 | #t 1230 | boot.lisp:359 1231 | EVAL_SUCCESS 1 1 1232 | (any num? (list "1" "2" "3")) 1233 | #f 1234 | boot.lisp:361 1235 | EVAL_ALL 4 1236 | 1237 | (defun partial (f . args-1) 1238 | (fun args-2 1239 | (apply f (append args-1 args-2)))) 1240 | boot.lisp:365 1241 | EVAL_SUCCESS 1 1 1242 | ((partial +)) 1243 | 0 1244 | boot.lisp:367 1245 | EVAL_SUCCESS 1 1 1246 | ((partial -) 1) 1247 | -1 1248 | boot.lisp:369 1249 | EVAL_SUCCESS 1 1 1250 | ((partial - 3) 1) 1251 | 2 1252 | boot.lisp:371 1253 | EVAL_SUCCESS 1 1 1254 | ((partial - 3 2) 1) 1255 | 0 1256 | boot.lisp:373 1257 | EVAL_SUCCESS 1 1 1258 | ((partial - 5 1) 2 3) 1259 | -1 1260 | boot.lisp:375 1261 | EVAL_ALL 45 1262 | 1263 | (defmacro quasiquote ls 1264 | (*qq (car ls))) 1265 | 1266 | (defun *qq (x) 1267 | (if (cons? x) 1268 | (cond 1269 | [(= (car x) 'unquote) 1270 | (cadr x)] 1271 | [(and (cons? (car x)) (= (caar x) 'unquote-splicing)) 1272 | (list 'append (cadar x) (*qq (cdr x)))] 1273 | [else 1274 | (list 'cons (*qq (car x)) (*qq (cdr x)))]) 1275 | (list 'quote x))) 1276 | 1277 | (defun *bind? (x) 1278 | (and (cons? x) 1279 | (cons? (cdr x)) 1280 | (nil? (cddr x)) 1281 | (sym? (car x)))) 1282 | 1283 | (defmacro let (binds . body) 1284 | (cond 1285 | [(sym? binds) 1286 | `(named-let ,binds ,@body)] 1287 | [(nil? binds) 1288 | `(begin ,@body)] 1289 | [(not (and (cons? binds) (*bind? (car binds)))) 1290 | (error "Syntax error: expected (let ((name expr)...) body...)")] 1291 | [else 1292 | `((fun (,(caar binds)) (let ,(cdr binds) ,@body)) 1293 | ,(cadar binds))])) 1294 | 1295 | (defmacro letrec (binds . body) 1296 | (if (and (list? binds) (all *bind? binds)) 1297 | (let ([vars (map (fun (x) `[,(car x) ()]) binds)] 1298 | [inits (map (fun (x) `(set! ,(car x) ,(cadr x))) binds)]) 1299 | `(let ,vars ,@inits ,@body)) 1300 | (error "Syntax error: expected (letrec ((name expr)...) body...)"))) 1301 | 1302 | (defmacro named-let (sym binds . body) 1303 | (if (and (list? binds) (all *bind? binds)) 1304 | (let ([args (map car binds)]) 1305 | `(let ,binds (letrec ([,sym (fun ,args ,@body)]) (,sym ,@args)))) 1306 | (error "Syntax error: expected (named-let name ((name expr)...) body...)"))) 1307 | boot.lisp:421 1308 | EVAL_SUCCESS 1 1 1309 | (let ([_x 2] [_y 3]) (* _x _y)) 1310 | 6 1311 | boot.lisp:423 1312 | EVAL_FAILURE 1 1313 | _x 1314 | boot.lisp:425 1315 | EVAL_SUCCESS 4 1 1316 | (let _loop ([x 10] [sum 0]) 1317 | (if (< 0 x) 1318 | (_loop (- x 1) (+ sum x)) 1319 | sum)) 1320 | 55 1321 | boot.lisp:430 1322 | EVAL_FAILURE 1 1323 | _loop 1324 | boot.lisp:432 1325 | EVAL_SUCCESS 1 1 1326 | (let ([x 3] [x (* x 4)] [x (+ x 5)]) x) 1327 | 17 1328 | boot.lisp:434 1329 | EVAL_SUCCESS 3 1 1330 | (letrec ([even? (fun (x) (if (= (% x 2) 0) #t (odd? (- x 1))))] 1331 | [odd? (fun (x) (if (= (% x 2) 0) #f (even? (- x 1))))]) 1332 | (list (even? 4) (even? 5) (odd? 6) (odd? 7))) 1333 | (#t #f #f #t) 1334 | boot.lisp:438 1335 | EVAL_ALL 3 1336 | 1337 | (defmacro when (cond . body) 1338 | `(if ,cond (begin ,@body) ())) 1339 | boot.lisp:441 1340 | EVAL_SUCCESS 1 1 1341 | (when #f 123 456) 1342 | () 1343 | boot.lisp:443 1344 | EVAL_SUCCESS 1 1 1345 | (when #t 123 456) 1346 | 456 1347 | boot.lisp:445 1348 | EVAL_ALL 3 1349 | 1350 | (defmacro unless (cond . body) 1351 | `(if ,cond () (begin ,@body))) 1352 | boot.lisp:448 1353 | EVAL_SUCCESS 1 1 1354 | (unless #f 123 456) 1355 | 456 1356 | boot.lisp:450 1357 | EVAL_SUCCESS 1 1 1358 | (unless #t 123 456) 1359 | () 1360 | boot.lisp:452 1361 | EVAL_ALL 3 1362 | 1363 | (defmacro let1 (var expr . body) 1364 | `(let ([,var ,expr]) ,@body)) 1365 | boot.lisp:455 1366 | EVAL_SUCCESS 4 1 1367 | (let1 x 3 1368 | (let1 x (* x 4) 1369 | (let1 x (+ x 5) 1370 | x))) 1371 | 17 1372 | boot.lisp:460 1373 | EVAL_ALL 6 1374 | 1375 | (defbuiltin call/cc (fun)) 1376 | (defbuiltin never (fun . args)) 1377 | 1378 | (defmacro let/cc (k . body) 1379 | `(call/cc (fun (,k) ,@body))) 1380 | boot.lisp:467 1381 | EVAL_SUCCESS 1 1 1382 | (+ 1 (let/cc cont (+ 10 (cont 100)))) 1383 | 101 1384 | boot.lisp:469 1385 | EVAL_SUCCESS 1 1 1386 | (+ 1 (let/cc cont (+ 10 100))) 1387 | 111 1388 | boot.lisp:471 1389 | EVAL_SUCCESS 7 1 1390 | (let ([x 10] [sum 0] [cont #f]) 1391 | (let/cc k (set! cont k)) 1392 | (when (< 0 x) 1393 | (set! sum (+ sum x)) 1394 | (set! x (- x 1)) 1395 | (cont)) 1396 | sum) 1397 | 55 1398 | boot.lisp:479 1399 | EVAL_ALL 31 1400 | 1401 | (defmacro shift (k . body) 1402 | `(*shift (fun (,k) ,@body))) 1403 | 1404 | (defmacro reset body 1405 | `(*reset (fun () ,@body))) 1406 | 1407 | (def *cont #f) 1408 | 1409 | (defun *abort (thunk) 1410 | (never 1411 | (fun () 1412 | (let1 v (thunk) 1413 | (*cont v))))) 1414 | 1415 | (defun *reset (thunk) 1416 | (let1 cont *cont 1417 | (let/cc k 1418 | (set! *cont 1419 | (fun (v) 1420 | (set! *cont cont) 1421 | (k v))) 1422 | (*abort thunk)))) 1423 | 1424 | (defun *shift (f) 1425 | (let/cc k 1426 | (*abort 1427 | (fun () 1428 | (f 1429 | (fun vs 1430 | (reset (apply k vs)))))))) 1431 | boot.lisp:511 1432 | EVAL_SUCCESS 5 1 1433 | (reset 1434 | (shift k (append '(1) (k))) 1435 | (shift k (append '(2) (k))) 1436 | (shift k (append '(3) (k))) 1437 | '()) 1438 | (1 2 3) 1439 | boot.lisp:517 1440 | EVAL_ALL 18 1441 | 1442 | (defun success (v) (cons #t v)) 1443 | (defun failure (v) (cons #f v)) 1444 | 1445 | (defun result (v) (cdr v)) 1446 | 1447 | (defun success? (v) (car v)) 1448 | (defun failure? (v) (not (car v))) 1449 | 1450 | (defun force-success (v) 1451 | (if (success? v) 1452 | (result v) 1453 | (error (result v)))) 1454 | 1455 | (defun force-failure (v) 1456 | (if (failure? v) 1457 | (result v) 1458 | (error "force-failure"))) 1459 | boot.lisp:536 1460 | EVAL_SUCCESS 1 1 1461 | (force-success (success 123)) 1462 | 123 1463 | boot.lisp:538 1464 | EVAL_FAILURE 1 1465 | (force-success (failure "error")) 1466 | boot.lisp:540 1467 | EVAL_FAILURE 1 1468 | (force-failure (success 123)) 1469 | boot.lisp:542 1470 | EVAL_SUCCESS 1 1 1471 | (force-failure (failure "error")) 1472 | "error" 1473 | boot.lisp:544 1474 | EVAL_ALL 11 1475 | 1476 | (def result-unit success) 1477 | 1478 | (defun result-bind (m f) 1479 | (if (success? m) (f (result m)) m)) 1480 | 1481 | (defmacro result-reify body 1482 | `(reset (result-unit (begin ,@body)))) 1483 | 1484 | (defun result-reflect (m) 1485 | (shift k (result-bind m k))) 1486 | boot.lisp:556 1487 | EVAL_SUCCESS 1 1 1488 | (result-reify 123) 1489 | (#t . 123) 1490 | boot.lisp:558 1491 | EVAL_SUCCESS 1 1 1492 | (result-reify (+ (result-reflect (success 123)) 456)) 1493 | (#t . 579) 1494 | boot.lisp:560 1495 | EVAL_SUCCESS 1 1 1496 | (result-reify (+ (result-reflect (failure "error")) 456)) 1497 | (#f . "error") 1498 | boot.lisp:562 1499 | EVAL_SUCCESS 1 1 1500 | (result-reify (let1 a (result-reify 123) (+ (result-reflect a) 1))) 1501 | (#t . 124) 1502 | boot.lisp:564 1503 | EVAL_SUCCESS 1 1 1504 | (result-reify (let1 a (result-reify (result-reflect (success 123))) (+ (result-reflect a) 1))) 1505 | (#t . 124) 1506 | boot.lisp:566 1507 | EVAL_SUCCESS 1 1 1508 | (result-reify (let1 a (result-reify (result-reflect (failure "error"))) (+ (result-reflect a) 1))) 1509 | (#f . "error") 1510 | boot.lisp:568 1511 | EVAL_SUCCESS 1 1 1512 | (result-reify (let1 a (result-reify (result-reflect (failure "error"))) a)) 1513 | (#t #f . "error") 1514 | boot.lisp:570 1515 | EVAL_ALL 8 1516 | 1517 | (def list-concat append) 1518 | 1519 | (defun list-count (xs) 1520 | (let loop ([xs xs] [c 0]) 1521 | (if (nil? xs) 1522 | c 1523 | (loop (cdr xs) (+ c 1))))) 1524 | boot.lisp:578 1525 | EVAL_SUCCESS 1 1 1526 | (list-count (list 1 3 4 5 6)) 1527 | 5 1528 | boot.lisp:580 1529 | EVAL_ALL 6 1530 | 1531 | (defun list-find (f ls) 1532 | (cond 1533 | [(nil? ls) ()] 1534 | [(f (car ls)) (car ls)] 1535 | [else (list-find f (cdr ls))])) 1536 | boot.lisp:586 1537 | EVAL_SUCCESS 1 1 1538 | (list-find num? (list "foo" 'bar 123 "baz" 456)) 1539 | 123 1540 | boot.lisp:588 1541 | EVAL_SUCCESS 1 1 1542 | (list-find num? (list "foo" 'bar "baz")) 1543 | () 1544 | boot.lisp:590 1545 | EVAL_ALL 6 1546 | 1547 | (defun list-lookup (k ls) 1548 | (cond 1549 | [(nil? ls) ()] 1550 | [(= (caar ls) k) (cdar ls)] 1551 | [else (list-lookup k (cdr ls))])) 1552 | boot.lisp:596 1553 | EVAL_SUCCESS 1 1 1554 | (list-lookup 2 '((1 . "foo") (2 . "bar") (3 . "baz"))) 1555 | "bar" 1556 | boot.lisp:598 1557 | EVAL_SUCCESS 1 1 1558 | (list-lookup 5 '((1 . "foo") (2 . "bar") (3 . "baz"))) 1559 | () 1560 | boot.lisp:600 1561 | EVAL_ALL 9 1562 | 1563 | (defun list-zip-with (f xs ys) 1564 | (if (or (nil? xs) (nil? ys)) 1565 | () 1566 | (cons (f (car xs) (car ys)) 1567 | (list-zip-with f (cdr xs) (cdr ys))))) 1568 | 1569 | (defun list-zip (xs ys) 1570 | (list-zip-with cons xs ys)) 1571 | boot.lisp:610 1572 | EVAL_SUCCESS 1 1 1573 | (list-zip '(1 2 3) '(a b c)) 1574 | ((1 . a) (2 . b) (3 . c)) 1575 | boot.lisp:612 1576 | EVAL_SUCCESS 1 1 1577 | (list-zip '(1 2 3) '(x y)) 1578 | ((1 . x) (2 . y)) 1579 | boot.lisp:614 1580 | EVAL_ALL 2 1581 | 1582 | (def list-ref (flip nth)) 1583 | boot.lisp:616 1584 | EVAL_SUCCESS 1 1 1585 | (list-ref (list 4 3 2) 0) 1586 | 4 1587 | boot.lisp:618 1588 | EVAL_ALL 4 1589 | 1590 | (def list-at nth) 1591 | 1592 | (defbuiltin str chars) 1593 | boot.lisp:622 1594 | EVAL_SUCCESS 1 1 1595 | (str 102) 1596 | "f" 1597 | boot.lisp:624 1598 | EVAL_SUCCESS 1 1 1599 | (str 102 111 111 98 97 114) 1600 | "foobar" 1601 | boot.lisp:626 1602 | EVAL_FAILURE 1 1603 | (str -1) 1604 | boot.lisp:628 1605 | EVAL_ALL 2 1606 | 1607 | (defbuiltin str-char-at (str n)) 1608 | boot.lisp:630 1609 | EVAL_SUCCESS 1 1 1610 | (str-char-at "foobar" 0) 1611 | 102 1612 | boot.lisp:632 1613 | EVAL_SUCCESS 1 1 1614 | (str-char-at "foobar" 1) 1615 | 111 1616 | boot.lisp:634 1617 | EVAL_SUCCESS 1 1 1618 | (str-char-at "foobar" 8) 1619 | () 1620 | boot.lisp:636 1621 | EVAL_ALL 2 1622 | 1623 | (defbuiltin str-length (str)) 1624 | boot.lisp:638 1625 | EVAL_SUCCESS 1 1 1626 | (str-length "foobar") 1627 | 6 1628 | boot.lisp:640 1629 | EVAL_FAILURE 1 1630 | (str-length "foobar" "baz") 1631 | boot.lisp:642 1632 | EVAL_ALL 3 1633 | 1634 | (defun str->list (str) 1635 | (map (partial str-char-at str) (iota 0 (str-length str)))) 1636 | boot.lisp:645 1637 | EVAL_SUCCESS 1 1 1638 | (str->list "foobar") 1639 | (102 111 111 98 97 114) 1640 | boot.lisp:647 1641 | EVAL_ALL 3 1642 | 1643 | (defun list->str (list) 1644 | (apply str list)) 1645 | boot.lisp:650 1646 | EVAL_SUCCESS 1 1 1647 | (list->str (list 102 111 111 98 97 114)) 1648 | "foobar" 1649 | boot.lisp:652 1650 | EVAL_ALL 2 1651 | 1652 | (defbuiltin str-concat strs) 1653 | boot.lisp:654 1654 | EVAL_SUCCESS 1 1 1655 | (str-concat) 1656 | "" 1657 | boot.lisp:656 1658 | EVAL_SUCCESS 1 1 1659 | (str-concat "foo" "bar" "baz") 1660 | "foobarbaz" 1661 | boot.lisp:658 1662 | EVAL_ALL 2 1663 | 1664 | (defbuiltin substr (str n length)) 1665 | boot.lisp:660 1666 | EVAL_SUCCESS 1 1 1667 | (substr "foobar" 0 3) 1668 | "foo" 1669 | boot.lisp:662 1670 | EVAL_SUCCESS 1 1 1671 | (substr "foobar" 2 3) 1672 | "oba" 1673 | boot.lisp:664 1674 | EVAL_SUCCESS 1 1 1675 | (substr "foobar" 1 4) 1676 | "ooba" 1677 | boot.lisp:666 1678 | EVAL_FAILURE 1 1679 | (substr "foobar" 1 10) 1680 | boot.lisp:668 1681 | EVAL_ALL 2 1682 | 1683 | (defbuiltin sym->str (sym)) 1684 | boot.lisp:670 1685 | EVAL_SUCCESS 1 1 1686 | (sym->str 'foo-bar) 1687 | "foo-bar" 1688 | boot.lisp:672 1689 | EVAL_ALL 2 1690 | 1691 | (defbuiltin num->str (num)) 1692 | boot.lisp:674 1693 | EVAL_SUCCESS 1 1 1694 | (num->str 123) 1695 | "123" 1696 | boot.lisp:676 1697 | EVAL_ALL 2 1698 | 1699 | (defbuiltin str->num (num)) 1700 | boot.lisp:678 1701 | EVAL_SUCCESS 1 1 1702 | (str->num "456") 1703 | 456 1704 | boot.lisp:680 1705 | EVAL_SUCCESS 1 1 1706 | (str->num "foo") 1707 | () 1708 | boot.lisp:682 1709 | EVAL_ALL 15 1710 | 1711 | (defun str-escape (str) 1712 | (list->str (*chars-escape (str->list str)))) 1713 | 1714 | (defun *chars-escape (chars) 1715 | (if (nil? chars) 1716 | () 1717 | (let ([l (car chars)] 1718 | [r (*chars-escape (cdr chars))]) 1719 | (cond 1720 | [(= l 92) (append '(92 92) r)] ; \\ 1721 | [(= l 9) (append '(92 116) r)] ; \t 1722 | [(= l 10) (append '(92 110) r)] ; \n 1723 | [(= l 34) (append '(92 34) r)] ; \" 1724 | [else (cons l r)])))) 1725 | boot.lisp:698 1726 | EVAL_SUCCESS 1 1 1727 | (str-escape "foo") 1728 | "foo" 1729 | boot.lisp:700 1730 | EVAL_SUCCESS 1 1 1731 | (str-escape "foo\"bar") 1732 | "foo\\\"bar" 1733 | boot.lisp:702 1734 | EVAL_SUCCESS 1 1 1735 | (str-escape "\t\t\n") 1736 | "\\t\\t\\n" 1737 | boot.lisp:704 1738 | EVAL_SUCCESS 1 1 1739 | (str-escape "peo\\ple") 1740 | "peo\\\\ple" 1741 | boot.lisp:706 1742 | EVAL_ALL 17 1743 | 1744 | (defun str-unescape (str) 1745 | (list->str (*chars-unescape (str->list str)))) 1746 | 1747 | (defun *chars-unescape (chars) 1748 | (cond 1749 | [(or (nil? chars) (nil? (cdr chars))) chars] 1750 | [(= (car chars) 92) 1751 | (let ([l (cadr chars)] 1752 | [r (*chars-unescape (cddr chars))]) 1753 | (cond 1754 | [(= l 92) (cons 92 r)] ; \\ 1755 | [(= l 116) (cons 9 r)] ; \t 1756 | [(= l 110) (cons 10 r)] ; \n 1757 | [(= l 34) (cons 34 r)] ; \" 1758 | [else (cons l r)]))] 1759 | [else (cons (car chars) (*chars-unescape (cdr chars)))])) 1760 | boot.lisp:724 1761 | EVAL_SUCCESS 1 1 1762 | (str-unescape "foo") 1763 | "foo" 1764 | boot.lisp:726 1765 | EVAL_SUCCESS 1 1 1766 | (str-unescape "foo\\\"bar") 1767 | "foo\"bar" 1768 | boot.lisp:728 1769 | EVAL_SUCCESS 1 1 1770 | (str-unescape "\\t\\t\\n") 1771 | "\t\t\n" 1772 | boot.lisp:730 1773 | EVAL_SUCCESS 1 1 1774 | (str-unescape "peo\\\\ple") 1775 | "peo\\ple" 1776 | boot.lisp:732 1777 | EVAL_ALL 23 1778 | 1779 | (defun str-find-index (s pred) 1780 | (let loop ([i 0]) 1781 | (cond 1782 | [(nil? (str-char-at s i)) ()] 1783 | [(pred (str-char-at s i)) i] 1784 | [else (loop (+ i 1))]))) 1785 | 1786 | (defun str-find-index-rev (s pred) 1787 | (let loop ([i (- (str-length s) 1)]) 1788 | (cond 1789 | [(nil? (str-char-at s i)) ()] 1790 | [(pred (str-char-at s i)) i] 1791 | [else (loop (- i 1))]))) 1792 | 1793 | (defun space-char? (c) 1794 | (or (= 32 c) (= 13 c) (= 10 c) (= 9 c))) 1795 | 1796 | (def non-space-char? 1797 | (compose not space-char?)) 1798 | 1799 | (defun line-separator-char? (c) 1800 | (or (= 13 c) (= 10 c))) 1801 | boot.lisp:756 1802 | EVAL_SUCCESS 1 1 1803 | (str-find-index "foo" non-space-char?) 1804 | 0 1805 | boot.lisp:758 1806 | EVAL_SUCCESS 1 1 1807 | (str-find-index " foo " non-space-char?) 1808 | 1 1809 | boot.lisp:760 1810 | EVAL_SUCCESS 1 1 1811 | (str-find-index " foo " non-space-char?) 1812 | 3 1813 | boot.lisp:762 1814 | EVAL_SUCCESS 1 1 1815 | (str-find-index "" non-space-char?) 1816 | () 1817 | boot.lisp:764 1818 | EVAL_SUCCESS 1 1 1819 | (str-find-index " " non-space-char?) 1820 | () 1821 | boot.lisp:766 1822 | EVAL_SUCCESS 1 1 1823 | (str-find-index-rev "foo" non-space-char?) 1824 | 2 1825 | boot.lisp:768 1826 | EVAL_SUCCESS 1 1 1827 | (str-find-index-rev " foo " non-space-char?) 1828 | 3 1829 | boot.lisp:770 1830 | EVAL_SUCCESS 1 1 1831 | (str-find-index-rev " foo " non-space-char?) 1832 | 5 1833 | boot.lisp:772 1834 | EVAL_SUCCESS 1 1 1835 | (str-find-index-rev "" non-space-char?) 1836 | () 1837 | boot.lisp:774 1838 | EVAL_SUCCESS 1 1 1839 | (str-find-index-rev " " non-space-char?) 1840 | () 1841 | boot.lisp:776 1842 | EVAL_ALL 12 1843 | 1844 | (defun str-trim-left (s) 1845 | (let1 i (str-find-index s non-space-char?) 1846 | (if (nil? i) 1847 | "" 1848 | (substr s i (- (str-length s) i))))) 1849 | 1850 | (defun str-trim-right (s) 1851 | (let1 i (str-find-index-rev s non-space-char?) 1852 | (if (nil? i) 1853 | "" 1854 | (substr s 0 (+ i 1))))) 1855 | boot.lisp:789 1856 | EVAL_SUCCESS 1 1 1857 | (str-trim-left "foo") 1858 | "foo" 1859 | boot.lisp:791 1860 | EVAL_SUCCESS 1 1 1861 | (str-trim-left " foo ") 1862 | "foo " 1863 | boot.lisp:793 1864 | EVAL_SUCCESS 1 1 1865 | (str-trim-left " \n foo") 1866 | "foo" 1867 | boot.lisp:795 1868 | EVAL_SUCCESS 1 1 1869 | (str-trim-left " ") 1870 | "" 1871 | boot.lisp:797 1872 | EVAL_SUCCESS 1 1 1873 | (str-trim-right "foo") 1874 | "foo" 1875 | boot.lisp:799 1876 | EVAL_SUCCESS 1 1 1877 | (str-trim-right " foo ") 1878 | " foo" 1879 | boot.lisp:801 1880 | EVAL_SUCCESS 1 1 1881 | (str-trim-right "foo \n ") 1882 | "foo" 1883 | boot.lisp:803 1884 | EVAL_SUCCESS 1 1 1885 | (str-trim-right " ") 1886 | "" 1887 | boot.lisp:805 1888 | EVAL_ALL 3 1889 | 1890 | (defun str-trim (s) 1891 | (str-trim-left (str-trim-right s))) 1892 | boot.lisp:809 1893 | EVAL_SUCCESS 1 1 1894 | (str-trim " \n foo ") 1895 | "foo" 1896 | boot.lisp:811 1897 | EVAL_ALL 6 1898 | 1899 | (defun str-split (s pred) 1900 | (let1 i (str-find-index s pred) 1901 | (if (nil? i) 1902 | (list s) 1903 | (cons (substr s 0 i) (str-split (substr s (+ i 1) (- (str-length s) i 1)) pred))))) 1904 | boot.lisp:818 1905 | EVAL_SUCCESS 1 1 1906 | (str-split "foo" space-char?) 1907 | ("foo") 1908 | boot.lisp:820 1909 | EVAL_SUCCESS 1 1 1910 | (str-split "foo bar" space-char?) 1911 | ("foo" "bar") 1912 | boot.lisp:822 1913 | EVAL_SUCCESS 1 1 1914 | (str-split "foo bar\nbaz" space-char?) 1915 | ("foo" "bar" "baz") 1916 | boot.lisp:824 1917 | EVAL_SUCCESS 1 1 1918 | (str-split " foo bar " space-char?) 1919 | ("" "foo" "" "bar" "") 1920 | boot.lisp:826 1921 | EVAL_SUCCESS 1 1 1922 | (str-split "" space-char?) 1923 | ("") 1924 | boot.lisp:828 1925 | EVAL_ALL 3 1926 | 1927 | (defun str-lines (s) 1928 | (str-split s line-separator-char?)) 1929 | boot.lisp:832 1930 | EVAL_SUCCESS 1 1 1931 | (str-lines "foo") 1932 | ("foo") 1933 | boot.lisp:834 1934 | EVAL_SUCCESS 1 1 1935 | (str-lines "foo\nbar\nbaz") 1936 | ("foo" "bar" "baz") 1937 | boot.lisp:836 1938 | EVAL_SUCCESS 1 1 1939 | (str-lines "\nfoo\n\nbar") 1940 | ("" "foo" "" "bar") 1941 | boot.lisp:838 1942 | EVAL_ALL 2 1943 | 1944 | (defbuiltin vec items) 1945 | boot.lisp:840 1946 | EVAL_SUCCESS 1 1 1947 | (vec 1 2 3) 1948 | (vec 1 2 3) 1949 | boot.lisp:842 1950 | EVAL_SUCCESS 1 1 1951 | (vec? (vec 1 2 3)) 1952 | #t 1953 | boot.lisp:844 1954 | EVAL_ALL 2 1955 | 1956 | (defbuiltin vec-make (length init)) 1957 | boot.lisp:846 1958 | EVAL_SUCCESS 1 1 1959 | (vec-make 5 #f) 1960 | (vec #f #f #f #f #f) 1961 | boot.lisp:848 1962 | EVAL_ALL 2 1963 | 1964 | (defbuiltin vec-get (vec n)) 1965 | boot.lisp:850 1966 | EVAL_SUCCESS 1 1 1967 | (vec-get (vec 4 9 3) 1) 1968 | 9 1969 | boot.lisp:852 1970 | EVAL_SUCCESS 1 1 1971 | (vec-get (vec 4 9 3) 4) 1972 | () 1973 | boot.lisp:854 1974 | EVAL_ALL 4 1975 | 1976 | (def vec-at (flip vec-get)) 1977 | 1978 | (defbuiltin vec-length (vec)) 1979 | boot.lisp:858 1980 | EVAL_SUCCESS 1 1 1981 | (vec-length (vec)) 1982 | 0 1983 | boot.lisp:860 1984 | EVAL_SUCCESS 1 1 1985 | (vec-length (vec 1 2 3 4 5)) 1986 | 5 1987 | boot.lisp:862 1988 | EVAL_ALL 2 1989 | 1990 | (defbuiltin vec-set! (vec n item)) 1991 | boot.lisp:864 1992 | EVAL_SUCCESS 4 1 1993 | (let1 v (vec-make 3 #f) 1994 | (vec-set! v 0 #t) 1995 | (vec-set! v 2 "k") 1996 | v) 1997 | (vec #t #f "k") 1998 | boot.lisp:869 1999 | EVAL_ALL 2 2000 | 2001 | (defbuiltin vec-copy! (dest dest-start src src-start length)) 2002 | boot.lisp:871 2003 | EVAL_SUCCESS 4 1 2004 | (let ([fs (vec 0 1 2 3 4 5)] 2005 | [ts (vec 6 7 8 9)]) 2006 | (vec-copy! fs 2 ts 1 3) 2007 | fs) 2008 | (vec 0 1 7 8 9 5) 2009 | boot.lisp:876 2010 | EVAL_FAILURE 4 2011 | (let ([fs (vec 0 1 2 3 4 5)] 2012 | [ts (vec 6 7 8 9)]) 2013 | (vec-copy! fs 4 ts 1 3) 2014 | fs) 2015 | boot.lisp:881 2016 | EVAL_FAILURE 4 2017 | (let ([fs (vec 0 1 2 3 4 5)] 2018 | [ts (vec 6 7 8 9)]) 2019 | (vec-copy! fs 1 ts 3 3) 2020 | fs) 2021 | boot.lisp:886 2022 | EVAL_ALL 3 2023 | 2024 | (defun vec->list (vec) 2025 | (map (partial vec-get vec) (iota 0 (vec-length vec)))) 2026 | boot.lisp:889 2027 | EVAL_SUCCESS 1 1 2028 | (vec->list (vec 1 3 5 7)) 2029 | (1 3 5 7) 2030 | boot.lisp:891 2031 | EVAL_ALL 3 2032 | 2033 | (defun list->vec (list) 2034 | (apply vec list)) 2035 | boot.lisp:894 2036 | EVAL_SUCCESS 1 1 2037 | (list->vec (list 1 3 5 7)) 2038 | (vec 1 3 5 7) 2039 | boot.lisp:896 2040 | EVAL_ALL 23 2041 | 2042 | (defmacro defrecord (name constructor-name predicate-name fields) 2043 | (unless (and (sym? name) 2044 | (or (sym? constructor-name) (= #f constructor-name)) 2045 | (or (sym? predicate-name) (= #f predicate-name)) 2046 | (list? fields) 2047 | (all list? fields) 2048 | (all (compose not nil?) fields) 2049 | (all (partial all sym?) fields)) 2050 | (error "Syntax error: expected (defrecord name predicate-name (fields...))")) 2051 | (let ([field-names (map car fields)] 2052 | [field-getter-names (map (fun (field) (and (cons? (cdr field)) (cadr field))) fields)] 2053 | [field-setter-names (map (fun (field) (and (cons? (cdr field)) (cons? (cddr field)) (caddr field))) fields)] 2054 | [field-indices (iota 1 (+ 1 (list-count fields)))] 2055 | [constructor (and constructor-name `(defun ,constructor-name ,field-names (vec ',name ,@field-names)))] 2056 | [predicate (and predicate-name `(defun ,predicate-name (v) (and (vec? v) (= ',name (vec-get v 0)))))] 2057 | [getters (list-zip-with (fun (i f) (and f `(defun ,f (v) (vec-get v ,i)))) field-indices field-getter-names)] 2058 | [setters (list-zip-with (fun (i f) (and f `(defun ,f (v x) (vec-set! v ,i x)))) field-indices field-setter-names)]) 2059 | `(begin 2060 | ,constructor 2061 | ,predicate 2062 | ,@(filter id getters) 2063 | ,@(filter id setters)))) 2064 | boot.lisp:920 2065 | EVAL_SUCCESS 3 1 2066 | (defrecord point point point? 2067 | ([x point-x] 2068 | [y point-y set-point-y!])) 2069 | () 2070 | boot.lisp:924 2071 | EVAL_SUCCESS 1 1 2072 | (def _p (point 12 34)) 2073 | () 2074 | boot.lisp:926 2075 | EVAL_SUCCESS 1 1 2076 | (list (point? _p) (point? 123)) 2077 | (#t #f) 2078 | boot.lisp:928 2079 | EVAL_SUCCESS 1 1 2080 | (list (point-x _p) (point-y _p)) 2081 | (12 34) 2082 | boot.lisp:930 2083 | EVAL_SUCCESS 1 1 2084 | (set-point-y! _p 56) 2085 | () 2086 | boot.lisp:932 2087 | EVAL_SUCCESS 1 1 2088 | (list (point-x _p) (point-y _p)) 2089 | (12 56) 2090 | boot.lisp:934 2091 | EVAL_ALL 37 2092 | 2093 | (defbuiltin read-file-text (filepath)) 2094 | (defbuiltin write-file-text (filepath str)) 2095 | 2096 | (defbuiltin read-console-line ()) 2097 | (defbuiltin write-console (str)) 2098 | 2099 | (defun inspect (x) 2100 | (cond 2101 | [(num? x) (num->str x)] 2102 | [(sym? x) (sym->str x)] 2103 | [(str? x) (str-concat "\"" (str-escape x) "\"")] 2104 | [(cons? x) (let ([l (car x)] 2105 | [r (cdr x)] 2106 | [a (list-lookup l *syntax-sugar)]) 2107 | (if (and (not (nil? a)) (cons? r) (nil? (cdr r))) 2108 | (str-concat a (inspect (car r))) 2109 | (str-concat "(" (*inspect-cons l r) ")")))] 2110 | [(nil? x) "()"] 2111 | [(= #t x) "#t"] 2112 | [(= #f x) "#f"] 2113 | [(proc? x) ""] 2114 | [(meta? x) ""] 2115 | [(vec? x) (inspect (cons 'vec (vec->list x)))] 2116 | [else (error)])) 2117 | 2118 | (def *syntax-sugar 2119 | '((quote . "'") 2120 | (quasiquote . "`") 2121 | (unquote . ",") 2122 | (unquote-splicing . ",@"))) 2123 | 2124 | (defun *inspect-cons (a b) 2125 | (cond 2126 | [(nil? b) (inspect a)] 2127 | [(cons? b) (str-concat (inspect a) " " (*inspect-cons (car b) (cdr b)))] 2128 | [else (str-concat (inspect a) " . " (inspect b))])) 2129 | boot.lisp:972 2130 | EVAL_SUCCESS 1 1 2131 | (inspect 123) 2132 | "123" 2133 | boot.lisp:974 2134 | EVAL_SUCCESS 1 1 2135 | (inspect 'foo) 2136 | "foo" 2137 | boot.lisp:976 2138 | EVAL_SUCCESS 1 1 2139 | (inspect "Hello, World!\n") 2140 | "\"Hello, World!\\n\"" 2141 | boot.lisp:978 2142 | EVAL_SUCCESS 1 1 2143 | (inspect ()) 2144 | "()" 2145 | boot.lisp:980 2146 | EVAL_SUCCESS 1 1 2147 | (inspect '(1)) 2148 | "(1)" 2149 | boot.lisp:982 2150 | EVAL_SUCCESS 1 1 2151 | (inspect '(1 a "b")) 2152 | "(1 a \"b\")" 2153 | boot.lisp:984 2154 | EVAL_SUCCESS 1 1 2155 | (inspect '(foo . bar)) 2156 | "(foo . bar)" 2157 | boot.lisp:986 2158 | EVAL_SUCCESS 1 1 2159 | (inspect '(foo bar . baz)) 2160 | "(foo bar . baz)" 2161 | boot.lisp:988 2162 | EVAL_SUCCESS 1 1 2163 | (map inspect (list ''foo ''(bar baz))) 2164 | ("'foo" "'(bar baz)") 2165 | boot.lisp:990 2166 | EVAL_SUCCESS 1 1 2167 | (inspect '`(foo ,bar ,@baz)) 2168 | "`(foo ,bar ,@baz)" 2169 | boot.lisp:992 2170 | EVAL_SUCCESS 1 1 2171 | (inspect '(quote foo bar)) 2172 | "(quote foo bar)" 2173 | boot.lisp:994 2174 | EVAL_SUCCESS 1 1 2175 | (inspect '(quote . foo)) 2176 | "(quote . foo)" 2177 | boot.lisp:996 2178 | EVAL_SUCCESS 1 1 2179 | (map inspect '(#t #f)) 2180 | ("#t" "#f") 2181 | boot.lisp:998 2182 | EVAL_SUCCESS 1 1 2183 | (map inspect (list (fun ()) = (macro ()) def)) 2184 | ("" "" "" "") 2185 | boot.lisp:1000 2186 | EVAL_SUCCESS 1 1 2187 | (inspect (vec 1 2 3)) 2188 | "(vec 1 2 3)" 2189 | boot.lisp:1002 2190 | EVAL_ALL 16 2191 | 2192 | (defun print strs 2193 | (map write-console strs) 2194 | ()) 2195 | 2196 | (defun println strs 2197 | (map write-console strs) 2198 | (write-console "\n") 2199 | ()) 2200 | 2201 | (defun p xs 2202 | (apply println (map inspect xs))) 2203 | 2204 | (def args ((builtin args))) 2205 | 2206 | (defbuiltin eval (s)) 2207 | boot.lisp:1018 2208 | EVAL_SUCCESS 1 1 2209 | (force-success (eval '(+ 1 2 3))) 2210 | 6 2211 | boot.lisp:1020 2212 | EVAL_FAILURE 1 2213 | (force-success (eval '(error))) 2214 | boot.lisp:1022 2215 | EVAL_ALL 3 2216 | 2217 | (defbuiltin macroexpand (s)) 2218 | (defbuiltin macroexpand-1 (s)) 2219 | boot.lisp:1025 2220 | EVAL_SUCCESS 1 1 2221 | (force-success (macroexpand 123)) 2222 | 123 2223 | boot.lisp:1027 2224 | EVAL_SUCCESS 1 1 2225 | (force-success (macroexpand '(defun foo (x y) (+ x y)))) 2226 | (def foo (fun (x y) (+ x y))) 2227 | boot.lisp:1029 2228 | EVAL_SUCCESS 1 1 2229 | (def _skip (macro (a . b) b)) 2230 | () 2231 | boot.lisp:1031 2232 | EVAL_SUCCESS 1 1 2233 | (force-success (macroexpand '(_skip 12 _skip 34 list 56 78))) 2234 | (list 56 78) 2235 | boot.lisp:1033 2236 | EVAL_SUCCESS 1 1 2237 | (force-success (macroexpand-1 '(_skip 12 _skip 34 list 56 78))) 2238 | (_skip 34 list 56 78) 2239 | boot.lisp:1035 2240 | EVAL_SUCCESS 1 1 2241 | (force-success (macroexpand '(list 12 (_skip 34 list 56 78)))) 2242 | (list 12 (list 56 78)) 2243 | boot.lisp:1037 2244 | EVAL_SUCCESS 1 1 2245 | (force-success (macroexpand-1 '(list 12 (_skip 34 list 56 78)))) 2246 | (list 12 (_skip 34 list 56 78)) 2247 | boot.lisp:1039 2248 | EVAL_FAILURE 1 2249 | (force-success (macroexpand '(_skip))) 2250 | contrib/stream.lisp:1 2251 | EVAL_ALL 45 2252 | (defrecord stream *stream stream? 2253 | ([body *stream-body *stream-set-body!] ; () | (cons item next-stream) 2254 | [forward *stream-forward])) 2255 | 2256 | (defun stream (input) 2257 | (letrec ([stream-head ()] 2258 | [forward 2259 | (fun () 2260 | (let1 next-stream-head (*stream () forward) 2261 | (*stream-set-body! stream-head (cons (input) next-stream-head)) 2262 | (set! stream-head next-stream-head)))]) 2263 | (set! stream-head (*stream () forward)) 2264 | stream-head)) 2265 | 2266 | (defun stream-peek (s) 2267 | (when (nil? (*stream-body s)) ((*stream-forward s))) 2268 | (car (*stream-body s))) 2269 | 2270 | (defun stream-next (s) 2271 | (if (= (stream-peek s) 'eof) 2272 | s 2273 | (cdr (*stream-body s)))) 2274 | 2275 | (defun stream-get (s) 2276 | (if (stream-eof? s) 2277 | (failure "eof") 2278 | (let ([r (stream-peek s)] 2279 | [s (stream-next s)]) 2280 | (success (cons r s))))) 2281 | 2282 | (defun stream-take (n s) 2283 | (let loop ([n n] 2284 | [s s] 2285 | [ret ()]) 2286 | (if (= n 0) 2287 | (success (reverse ret)) 2288 | (let1 r (stream-get s) 2289 | (if (success? r) 2290 | (loop (- n 1) 2291 | (cdr (result r)) 2292 | (cons (car (result r)) ret)) 2293 | r))))) 2294 | 2295 | (defun stream-eof? (s) 2296 | (= (stream-peek s) 'eof)) 2297 | contrib/stream.lisp:47 2298 | EVAL_SUCCESS 1 1 2299 | (def _x 0) 2300 | () 2301 | contrib/stream.lisp:49 2302 | EVAL_SUCCESS 1 1 2303 | (def _s1 (stream (fun () (set! _x (+ _x 1)) _x))) 2304 | () 2305 | contrib/stream.lisp:51 2306 | EVAL_SUCCESS 1 1 2307 | (stream-peek _s1) 2308 | 1 2309 | contrib/stream.lisp:53 2310 | EVAL_SUCCESS 1 1 2311 | (stream-peek _s1) 2312 | 1 2313 | contrib/stream.lisp:55 2314 | EVAL_SUCCESS 1 1 2315 | (def _s2 (stream-next _s1)) 2316 | () 2317 | contrib/stream.lisp:57 2318 | EVAL_SUCCESS 1 1 2319 | (cons (stream-peek _s1) (stream-peek _s2)) 2320 | (1 . 2) 2321 | contrib/stream.lisp:59 2322 | EVAL_SUCCESS 1 1 2323 | (set! _s1 (stream-next (stream-next _s1))) 2324 | () 2325 | contrib/stream.lisp:61 2326 | EVAL_SUCCESS 1 1 2327 | (cons (stream-peek _s1) (stream-peek _s2)) 2328 | (3 . 2) 2329 | contrib/stream.lisp:63 2330 | EVAL_SUCCESS 1 1 2331 | (set! _s1 (force-success (stream-get _s1))) 2332 | () 2333 | contrib/stream.lisp:65 2334 | EVAL_SUCCESS 1 1 2335 | (cons (car _s1) (stream-peek (cdr _s1))) 2336 | (3 . 4) 2337 | contrib/stream.lisp:67 2338 | EVAL_SUCCESS 1 1 2339 | (force-success (stream-take 4 _s2)) 2340 | (2 3 4 5) 2341 | contrib/stream.lisp:69 2342 | EVAL_ALL 9 2343 | 2344 | (defun list->stream (ls) 2345 | (stream 2346 | (fun () 2347 | (if (nil? ls) 2348 | 'eof 2349 | (let1 r (car ls) 2350 | (set! ls (cdr ls)) 2351 | r))))) 2352 | contrib/stream.lisp:78 2353 | EVAL_SUCCESS 1 1 2354 | (force-success (stream-take 4 (list->stream (list 1 2 3 4 5)))) 2355 | (1 2 3 4) 2356 | contrib/stream.lisp:80 2357 | EVAL_ALL 5 2358 | 2359 | (defun stream->list (s) 2360 | (if (stream-eof? s) 2361 | () 2362 | (cons (stream-peek s) (stream->list (stream-next s))))) 2363 | contrib/stream.lisp:85 2364 | EVAL_SUCCESS 1 1 2365 | (stream->list (list->stream (list 1 2 3))) 2366 | (1 2 3) 2367 | contrib/stream.lisp:87 2368 | EVAL_ALL 10 2369 | 2370 | (defun str->stream (str) 2371 | (let1 i 0 2372 | (stream 2373 | (fun () 2374 | (if (< i (str-length str)) 2375 | (let1 r (str-char-at str i) 2376 | (set! i (+ i 1)) 2377 | r) 2378 | 'eof))))) 2379 | contrib/stream.lisp:97 2380 | EVAL_SUCCESS 1 1 2381 | (force-success (stream-take 3 (str->stream "abc"))) 2382 | (97 98 99) 2383 | contrib/stream.lisp:99 2384 | EVAL_FAILURE 1 2385 | (force-success (stream-take 4 (str->stream "abc"))) 2386 | contrib/stream.lisp:101 2387 | EVAL_ALL 3 2388 | 2389 | (defun stream->str (s) 2390 | (apply str (stream->list s))) 2391 | contrib/stream.lisp:104 2392 | EVAL_SUCCESS 1 1 2393 | (stream->str (list->stream (list 97 98 99))) 2394 | "abc" 2395 | contrib/parser-combinators.lisp:1 2396 | EVAL_ALL 66 2397 | ; (input) => (result . input) | #f 2398 | ; tested in parser-combinators-stream 2399 | 2400 | (defun parse (p i) 2401 | (let1 r (p i) 2402 | (if r 2403 | (success r) 2404 | (failure "Parse error")))) 2405 | 2406 | (defun p-unit (x) 2407 | (fun (i) (cons x i))) 2408 | 2409 | (defun p-bind (m f) 2410 | (fun (i) 2411 | (let1 x (m i) 2412 | (and x ((f (car x)) (cdr x)))))) 2413 | 2414 | (def p-fail 2415 | (fun (i) #f)) 2416 | 2417 | (defmacro p-reify body 2418 | `(reset (p-unit (begin ,@body)))) 2419 | 2420 | (defun p-reflect (m) 2421 | (shift k (p-bind m k))) 2422 | 2423 | (defmacro p-lazy (p) 2424 | `(fun (i) (,p i))) 2425 | 2426 | (defun p-map (f p) 2427 | (p-reify 2428 | (let1 x (p-reflect p) 2429 | (f x)))) 2430 | 2431 | (defun p-where (f p) 2432 | (fun (i) 2433 | (let1 x (p i) 2434 | (and x (f (car x)) x)))) 2435 | 2436 | (defun p-or (p q) 2437 | (fun (i) 2438 | (or (p i) (q i)))) 2439 | 2440 | (defun p-cons (p q) 2441 | (p-reify 2442 | (let ([x (p-reflect p)] 2443 | [y (p-reflect q)]) 2444 | (cons x y)))) 2445 | 2446 | (def p-nil (p-unit ())) 2447 | 2448 | (defun p-choice ps 2449 | (foldr p-or p-fail ps)) 2450 | 2451 | (defun p-seq ps 2452 | (foldr p-cons p-nil ps)) 2453 | 2454 | (defun p-some (p) 2455 | (p-cons p (p-many p))) 2456 | 2457 | (defun p-many (p) 2458 | (p-lazy 2459 | (p-choice (p-some p) p-nil))) 2460 | 2461 | (defun p-reduce (f . args) 2462 | (p-map (partial apply f) (apply p-seq args))) 2463 | contrib/parser-combinators-stream.lisp:1 2464 | EVAL_ALL 4 2465 | (defun parse-just (p stream) 2466 | (let1 p (p-reduce (fun (x _) x) p ps-eof) 2467 | (result-reify 2468 | (car (result-reflect (parse p stream)))))) 2469 | contrib/parser-combinators-stream.lisp:6 2470 | EVAL_SUCCESS 3 1 2471 | (defun ps-test (p str) 2472 | (let1 r (p (str->stream str)) 2473 | (and r (cons (car r) (stream->str (cdr r)))))) 2474 | () 2475 | contrib/parser-combinators-stream.lisp:10 2476 | EVAL_ALL 25 2477 | 2478 | ; Predicates 2479 | 2480 | (defun char-class (s) 2481 | (let ([inverse? (= (str-char-at s 0) 94)] 2482 | [ls (str->list s)] 2483 | [fs (*char-class (if inverse? (cdr ls) ls))]) 2484 | (if inverse? 2485 | (fun (i) (all (fun (f) (not (f i))) fs)) 2486 | (fun (i) (any (fun (f) (f i)) fs))))) 2487 | 2488 | (defun *char-class (ls) 2489 | (cond 2490 | [(nil? ls) ()] 2491 | [(or (nil? (cdr ls)) (nil? (cddr ls))) (map *char-class-unit ls)] 2492 | [(= (nth 1 ls) 45) (cons (*char-class-range (nth 0 ls) (nth 2 ls)) 2493 | (*char-class (cdddr ls)))] 2494 | [else (cons (*char-class-unit (car ls)) 2495 | (*char-class (cdr ls)))])) 2496 | 2497 | (defun *char-class-unit (x) 2498 | (fun (i) (= i x))) 2499 | 2500 | (defun *char-class-range (x y) 2501 | (fun (i) (<= x i y))) 2502 | contrib/parser-combinators-stream.lisp:36 2503 | EVAL_SUCCESS 1 1 2504 | (map (char-class "a-fstx-z") (str->list "abcfgtuwy")) 2505 | (#t #t #t #t #f #t #f #f #t) 2506 | contrib/parser-combinators-stream.lisp:38 2507 | EVAL_SUCCESS 1 1 2508 | (map (char-class "^a-fstx-z") (str->list "abcfgtuwy")) 2509 | (#f #f #f #f #t #f #t #t #f) 2510 | contrib/parser-combinators-stream.lisp:40 2511 | EVAL_ALL 5 2512 | 2513 | ; Parser combinators 2514 | 2515 | (defun ps-any (i) 2516 | (and (not (= (stream-peek i) 'eof)) (cons (stream-peek i) (stream-next i)))) 2517 | contrib/parser-combinators-stream.lisp:45 2518 | EVAL_SUCCESS 1 1 2519 | (ps-test ps-any "abc") 2520 | (97 . "bc") 2521 | contrib/parser-combinators-stream.lisp:47 2522 | EVAL_SUCCESS 1 1 2523 | (ps-test ps-any "") 2524 | #f 2525 | contrib/parser-combinators-stream.lisp:49 2526 | EVAL_ALL 3 2527 | 2528 | (defun ps-eof (i) 2529 | (and (= (stream-peek i) 'eof) (cons () i))) 2530 | contrib/parser-combinators-stream.lisp:52 2531 | EVAL_SUCCESS 1 1 2532 | (ps-test ps-eof "") 2533 | (() . "") 2534 | contrib/parser-combinators-stream.lisp:54 2535 | EVAL_SUCCESS 1 1 2536 | (ps-test ps-eof "abc") 2537 | #f 2538 | contrib/parser-combinators-stream.lisp:56 2539 | EVAL_ALL 2 2540 | 2541 | ; p-unit 2542 | contrib/parser-combinators-stream.lisp:58 2543 | EVAL_SUCCESS 1 1 2544 | (ps-test (p-unit "Hello") "abc") 2545 | ("Hello" . "abc") 2546 | contrib/parser-combinators-stream.lisp:60 2547 | EVAL_ALL 2 2548 | 2549 | ; p-bind 2550 | contrib/parser-combinators-stream.lisp:62 2551 | EVAL_SUCCESS 3 1 2552 | (ps-test (p-bind ps-any (fun (a) 2553 | (p-bind ps-any (fun (b) 2554 | (p-unit (cons a b)))))) "abc") 2555 | ((97 . 98) . "c") 2556 | contrib/parser-combinators-stream.lisp:66 2557 | EVAL_ALL 2 2558 | 2559 | ; p-fail 2560 | contrib/parser-combinators-stream.lisp:68 2561 | EVAL_SUCCESS 1 1 2562 | (ps-test p-fail "abc") 2563 | #f 2564 | contrib/parser-combinators-stream.lisp:70 2565 | EVAL_SUCCESS 3 1 2566 | (ps-test (p-bind ps-any (fun (a) 2567 | (p-bind p-fail (fun (b) 2568 | (p-unit (cons a b)))))) "abc") 2569 | #f 2570 | contrib/parser-combinators-stream.lisp:74 2571 | EVAL_ALL 4 2572 | 2573 | (def ps-char 2574 | (p-map str ps-any)) 2575 | ; p-map 2576 | contrib/parser-combinators-stream.lisp:78 2577 | EVAL_SUCCESS 1 1 2578 | (ps-test ps-char "abc") 2579 | ("a" . "bc") 2580 | contrib/parser-combinators-stream.lisp:80 2581 | EVAL_ALL 4 2582 | 2583 | (defun ps-if (f) 2584 | (p-where f ps-any)) 2585 | ; p-where 2586 | contrib/parser-combinators-stream.lisp:84 2587 | EVAL_SUCCESS 1 1 2588 | (ps-test (ps-if (char-class "ab")) "abc") 2589 | (97 . "bc") 2590 | contrib/parser-combinators-stream.lisp:86 2591 | EVAL_SUCCESS 1 1 2592 | (ps-test (ps-if (char-class "ab")) "def") 2593 | #f 2594 | contrib/parser-combinators-stream.lisp:88 2595 | EVAL_ALL 3 2596 | 2597 | (defun ps-char-if (f) 2598 | (p-map str (ps-if f))) 2599 | contrib/parser-combinators-stream.lisp:91 2600 | EVAL_SUCCESS 1 1 2601 | (ps-test (ps-char-if (char-class "ab")) "abc") 2602 | ("a" . "bc") 2603 | contrib/parser-combinators-stream.lisp:93 2604 | EVAL_ALL 2 2605 | 2606 | ; p-or, p-choice 2607 | contrib/parser-combinators-stream.lisp:95 2608 | EVAL_SUCCESS 8 1 2609 | (let ([ab (ps-char-if (char-class "ab"))] 2610 | [ac (ps-char-if (char-class "ac"))] 2611 | [add-suffix (fun (s) (str-concat s "-"))] 2612 | [p (p-choice ab (p-map add-suffix ac))]) 2613 | (list (ps-test p "abcd") 2614 | (ps-test p "bcda") 2615 | (ps-test p "cdab") 2616 | (ps-test p "dabc"))) 2617 | (("a" . "bcd") ("b" . "cda") ("c-" . "dab") #f) 2618 | contrib/parser-combinators-stream.lisp:104 2619 | EVAL_ALL 2 2620 | 2621 | ; p-cons, p-nil, p-seq 2622 | contrib/parser-combinators-stream.lisp:106 2623 | EVAL_SUCCESS 7 1 2624 | (let1 p (p-seq (ps-char-if (char-class "ab")) 2625 | (ps-char-if (char-class "12")) 2626 | (ps-char-if (char-class "xy"))) 2627 | (list (ps-test p "c2xo") 2628 | (ps-test p "a3yp") 2629 | (ps-test p "b1zq") 2630 | (ps-test p "a1xr"))) 2631 | (#f #f #f (("a" "1" "x") . "r")) 2632 | contrib/parser-combinators-stream.lisp:114 2633 | EVAL_ALL 6 2634 | 2635 | (defun ps-list (xs) 2636 | (apply p-seq (map (fun (x) (ps-if (fun (y) (= x y)))) xs))) 2637 | 2638 | (defun ps-str (s) 2639 | (p-map (const s) (ps-list (str->list s)))) 2640 | contrib/parser-combinators-stream.lisp:121 2641 | EVAL_SUCCESS 1 1 2642 | (ps-test (ps-str "foo") "bar") 2643 | #f 2644 | contrib/parser-combinators-stream.lisp:123 2645 | EVAL_SUCCESS 1 1 2646 | (ps-test (ps-str "bar") "bar") 2647 | ("bar" . "") 2648 | contrib/parser-combinators-stream.lisp:125 2649 | EVAL_SUCCESS 1 1 2650 | (ps-test (ps-str "baz") "bar") 2651 | #f 2652 | contrib/parser-combinators-stream.lisp:127 2653 | EVAL_ALL 2 2654 | 2655 | ; p-many, p-some 2656 | contrib/parser-combinators-stream.lisp:129 2657 | EVAL_SUCCESS 9 1 2658 | (let ([p0 (p-many (ps-str "a"))] 2659 | [p1 (p-some (ps-str "a"))]) 2660 | (list (ps-test p0 "") 2661 | (ps-test p0 "a") 2662 | (ps-test p0 "aaa") 2663 | (ps-test p0 "aabb") 2664 | (ps-test p1 "") 2665 | (ps-test p1 "a") 2666 | (ps-test p1 "aabb"))) 2667 | ((() . "") (("a") . "") (("a" "a" "a") . "") (("a" "a") . "bb") #f (("a") . "") (("a" "a") . "bb")) 2668 | contrib/parser-combinators-stream.lisp:139 2669 | EVAL_ALL 2 2670 | 2671 | ; p-reduce 2672 | contrib/parser-combinators-stream.lisp:141 2673 | EVAL_SUCCESS 3 1 2674 | (ps-test (p-reduce + (p-map (fun (n) (* n 10000)) ps-any) 2675 | (p-map (fun (n) (* n 100)) ps-any) 2676 | ps-any) "abcdef") 2677 | (979899 . "def") 2678 | contrib/parser-combinators-stream.lisp:145 2679 | EVAL_ALL 3 2680 | 2681 | (defun ps-str-while (f) 2682 | (p-map (fun (ls) (apply str ls)) (p-some (ps-if f)))) 2683 | contrib/parser-combinators-stream.lisp:148 2684 | EVAL_SUCCESS 1 1 2685 | (ps-test (ps-str-while (char-class "abc")) "ababcbadcba") 2686 | ("ababcba" . "dcba") 2687 | contrib/parser-combinators-stream.lisp:150 2688 | EVAL_SUCCESS 1 1 2689 | (ps-test (ps-str-while (char-class "abc")) "defabcdef") 2690 | #f 2691 | contrib/tbl.lisp:1 2692 | EVAL_ALL 113 2693 | (defun *str-hash (str) 2694 | (let loop ([i 0] 2695 | [r 0] 2696 | [p 1]) 2697 | (if (<= (str-length str) i) 2698 | r 2699 | (loop (+ i 1) 2700 | (+ r (* p (str-char-at str i))) 2701 | (% (* p 257) 2038177))))) 2702 | 2703 | (def *tbl-capacity-provider 2704 | (list->stream (list 17 31 61 101 211 421 877 1663 3323 6871 14173 28439 57457 112771 232607))) 2705 | 2706 | (def *tbl-threshold 0.8) 2707 | 2708 | (defun *tbl-f (hash M) 2709 | (% hash M)) 2710 | 2711 | (defun *tbl-g (hash M) 2712 | (+ 1 (% hash (- M 1)))) 2713 | 2714 | (defun *tbl-h (hash M i) 2715 | (% (+ (*tbl-f hash M) 2716 | (* i (*tbl-g hash M))) 2717 | M)) 2718 | 2719 | (defrecord tbl *tbl tbl? 2720 | ([capacity *tbl-capacity *tbl-set-capacity!] 2721 | [length-total *tbl-length-total *tbl-set-length-total!] 2722 | [length-removed *tbl-length-removed *tbl-set-length-removed!] 2723 | [payload *tbl-payload *tbl-set-payload!])) 2724 | 2725 | ; = (vec ...) 2726 | ; = (key . value) | key | #f 2727 | 2728 | (defun tbl () 2729 | (let1 t (*tbl () () () ()) 2730 | (tbl-clear! t) 2731 | t)) 2732 | 2733 | (defun tbl-clear! (t) 2734 | (*tbl-set-capacity! t *tbl-capacity-provider) 2735 | (*tbl-set-length-total! t 0) 2736 | (*tbl-set-length-removed! t 0) 2737 | (*tbl-set-payload! t (vec-make (stream-peek *tbl-capacity-provider) #f))) 2738 | 2739 | (defun tbl-justify! (tbl additional-capacity) 2740 | (let ([payload-required-length (+ (*tbl-length-total tbl) additional-capacity)] 2741 | [required-length (- payload-required-length (*tbl-length-removed tbl))] 2742 | [usable-length (* (stream-peek (*tbl-capacity tbl)) *tbl-threshold)]) 2743 | ; NOTE: tbl never shrinks. 2744 | (when (< usable-length payload-required-length) 2745 | (let ([payload (*tbl-payload tbl)] 2746 | [new-capacity (*tbl-forward-capacity (*tbl-capacity tbl) required-length)] 2747 | [new-payload (vec-make (stream-peek new-capacity) #f)]) 2748 | (*tbl-set-capacity! tbl new-capacity) 2749 | (*tbl-set-length-total! tbl 0) 2750 | (*tbl-set-length-removed! tbl 0) 2751 | (*tbl-set-payload! tbl new-payload) 2752 | (*tbl-migrate! payload tbl))))) 2753 | 2754 | (defun *tbl-forward-capacity (s length) 2755 | (cond 2756 | [(= 'eof (stream-peek s)) (error "Too much elements")] 2757 | [(< (* (stream-peek s) *tbl-threshold) length) (*tbl-forward-capacity (stream-next s) length)] 2758 | [else s])) 2759 | 2760 | (defun *tbl-migrate! (payload tbl) 2761 | (let loop ([i 0]) 2762 | (when (< i (vec-length payload)) 2763 | (let1 item (vec-get payload i) 2764 | (when (cons? item) 2765 | (tbl-insert! tbl (car item) (cdr item))) 2766 | (loop (+ i 1)))))) 2767 | 2768 | (defun *tbl-find-index (tbl key) 2769 | (let ([M (stream-peek (*tbl-capacity tbl))] 2770 | [hash (*str-hash key)] 2771 | [match? (fun (v) 2772 | (or (not v) 2773 | (= v key) 2774 | (and (cons? v) (= (car v) key))))]) 2775 | (let loop ([i 0]) 2776 | (let1 index (*tbl-h hash M i) 2777 | (if (match? (vec-get (*tbl-payload tbl) index)) 2778 | index 2779 | (loop (+ i 1))))))) 2780 | 2781 | (defun *tbl-find (tbl key) 2782 | (vec-get (*tbl-payload tbl) (*tbl-find-index tbl key))) 2783 | 2784 | (defun tbl-contains? (tbl key) 2785 | (cons? (*tbl-find tbl key))) 2786 | 2787 | (defun tbl-find (tbl key) 2788 | (let1 r (*tbl-find tbl key) 2789 | (if (cons? r) (cdr r) ()))) 2790 | 2791 | (defun tbl-insert! (tbl key value) 2792 | (tbl-justify! tbl 1) 2793 | (let ([index (*tbl-find-index tbl key)] 2794 | [prev (vec-get (*tbl-payload tbl) index)]) 2795 | (vec-set! (*tbl-payload tbl) index (cons key value)) 2796 | (cond 2797 | [(not prev) (*tbl-set-length-total! tbl (+ (*tbl-length-total tbl) 1))] 2798 | [(str? prev) (*tbl-set-length-removed! tbl (- (*tbl-length-removed tbl) 1))]))) 2799 | 2800 | (defun tbl-remove! (tbl key) 2801 | (let ([index (*tbl-find-index tbl key)] 2802 | [prev (vec-get (*tbl-payload tbl) index)]) 2803 | (when (cons? prev) 2804 | (vec-set! (*tbl-payload tbl) index key) 2805 | (*tbl-set-length-removed! tbl (+ (*tbl-length-removed tbl) 1))))) 2806 | contrib/tbl.lisp:115 2807 | EVAL_SUCCESS 1 1 2808 | (tbl? (tbl)) 2809 | #t 2810 | contrib/tbl.lisp:117 2811 | EVAL_SUCCESS 1 1 2812 | (tbl? 123) 2813 | #f 2814 | contrib/tbl.lisp:119 2815 | EVAL_SUCCESS 1 1 2816 | (def _t (tbl)) 2817 | () 2818 | contrib/tbl.lisp:121 2819 | EVAL_SUCCESS 1 1 2820 | (tbl-contains? _t "foo") 2821 | #f 2822 | contrib/tbl.lisp:123 2823 | EVAL_SUCCESS 1 1 2824 | (tbl-insert! _t "foo" 123) 2825 | () 2826 | contrib/tbl.lisp:125 2827 | EVAL_SUCCESS 1 1 2828 | (tbl-contains? _t "foo") 2829 | #t 2830 | contrib/tbl.lisp:127 2831 | EVAL_SUCCESS 1 1 2832 | (tbl-find _t "foo") 2833 | 123 2834 | contrib/tbl.lisp:129 2835 | EVAL_SUCCESS 1 1 2836 | (list (tbl-contains? _t "bar") (tbl-find _t "bar")) 2837 | (#f ()) 2838 | contrib/tbl.lisp:131 2839 | EVAL_SUCCESS 1 1 2840 | (tbl-insert! _t "bar" 456) 2841 | () 2842 | contrib/tbl.lisp:133 2843 | EVAL_SUCCESS 1 1 2844 | (list (tbl-find _t "foo") (tbl-find _t "bar") (tbl-find _t "baz")) 2845 | (123 456 ()) 2846 | contrib/tbl.lisp:135 2847 | EVAL_SUCCESS 1 1 2848 | (tbl-remove! _t "foo") 2849 | () 2850 | contrib/tbl.lisp:137 2851 | EVAL_SUCCESS 1 1 2852 | (tbl-remove! _t "baz") 2853 | () 2854 | contrib/tbl.lisp:139 2855 | EVAL_SUCCESS 1 1 2856 | (list (tbl-find _t "foo") (tbl-find _t "bar") (tbl-find _t "baz")) 2857 | (() 456 ()) 2858 | contrib/tbl.lisp:141 2859 | EVAL_SUCCESS 1 1 2860 | (begin (for (iota 0 1000) (fun (i) (tbl-insert! _t (num->str i) (* i 2)))) ()) 2861 | () 2862 | contrib/tbl.lisp:143 2863 | EVAL_SUCCESS 1 1 2864 | (foldr + 0 (map (fun (i) (tbl-find _t (num->str i))) (iota 0 301))) 2865 | 90300 2866 | contrib/tbl.lisp:145 2867 | EVAL_ALL 7 2868 | 2869 | (defun *tbl-information (tbl) 2870 | (list 'tbl-information 2871 | (list 'capacity (stream-peek (*tbl-capacity tbl))) 2872 | (list 'used (*tbl-length-total tbl)) 2873 | (list 'removed (*tbl-length-removed tbl)) 2874 | (list 'items (filter cons? (vec->list (*tbl-payload tbl)))))) 2875 | -------------------------------------------------------------------------------- /testsuites/compiler: -------------------------------------------------------------------------------- 1 | > 123 2 | [0 entry] 3 | ldc 123 4 | 5 | > "foo" 6 | [0 entry] 7 | ldc "foo" 8 | 9 | > foo 10 | [0 entry] 11 | ldv foo 12 | 13 | > (foo) 14 | [0 entry] 15 | ldv foo 16 | app 0 17 | 18 | > (foo bar baz) 19 | [0 entry] 20 | ldv foo 21 | ldv bar 22 | ldv baz 23 | app 2 24 | 25 | > (foo (bar (baz)) hoge) 26 | [0 entry] 27 | ldv foo 28 | ldv bar 29 | ldv baz 30 | app 0 31 | app 1 32 | ldv hoge 33 | app 2 34 | 35 | > (foo . bar) 36 | fail 37 | 38 | > (a b c . d) 39 | fail 40 | 41 | > (begin) 42 | [0 entry] 43 | ldc () 44 | 45 | > (begin x) 46 | [0 entry] 47 | ldv x 48 | 49 | > (begin x y) 50 | [0 entry] 51 | ldv x 52 | pop 53 | ldv y 54 | 55 | > (begin a (b c) d) 56 | [0 entry] 57 | ldv a 58 | pop 59 | ldv b 60 | ldv c 61 | app 1 62 | pop 63 | ldv d 64 | 65 | > (def hello 123) 66 | [0 entry] 67 | ldc 123 68 | def hello 69 | ldc () 70 | 71 | > (def hello (a b)) 72 | [0 entry] 73 | ldv a 74 | ldv b 75 | app 1 76 | def hello 77 | ldc () 78 | 79 | > (set! goodbye (c d)) 80 | [0 entry] 81 | ldv c 82 | ldv d 83 | app 1 84 | set goodbye 85 | ldc () 86 | 87 | > (def hello) 88 | fail 89 | 90 | > (def (foo bar) 123) 91 | fail 92 | 93 | > (def "string" 42) 94 | fail 95 | 96 | > (if a b c) 97 | [0 entry] 98 | ldv a 99 | sel [1 then] [2 else] 100 | [1 then] 101 | ldv b 102 | leave 103 | [2 else] 104 | ldv c 105 | leave 106 | 107 | > (if a b) 108 | fail 109 | 110 | > (if (a b) (x y) z) 111 | [0 entry] 112 | ldv a 113 | ldv b 114 | app 1 115 | sel [1 then] [2 else] 116 | [1 then] 117 | ldv x 118 | ldv y 119 | app 1 120 | leave 121 | [2 else] 122 | ldv z 123 | leave 124 | 125 | > (if (if a b c) (if d e f) (if g h i)) 126 | [0 entry] 127 | ldv a 128 | sel [1 then] [2 else] 129 | sel [3 then] [6 else] 130 | [1 then] 131 | ldv b 132 | leave 133 | [2 else] 134 | ldv c 135 | leave 136 | [3 then] 137 | ldv d 138 | sel [4 then] [5 else] 139 | leave 140 | [4 then] 141 | ldv e 142 | leave 143 | [5 else] 144 | ldv f 145 | leave 146 | [6 else] 147 | ldv g 148 | sel [7 then] [8 else] 149 | leave 150 | [7 then] 151 | ldv h 152 | leave 153 | [8 else] 154 | ldv i 155 | leave 156 | 157 | > (if a b c d) 158 | fail 159 | 160 | > (fun ()) 161 | [0 entry] 162 | ldf [1 fun ()] 163 | [1 fun ()] 164 | ldc () 165 | leave 166 | 167 | > (fun () 12 34) 168 | [0 entry] 169 | ldf [1 fun ()] 170 | [1 fun ()] 171 | ldc 12 172 | pop 173 | ldc 34 174 | leave 175 | 176 | > (fun "x") 177 | fail 178 | 179 | > (fun abc) 180 | [0 entry] 181 | ldf [1 fun abc] 182 | [1 fun abc] 183 | ldc () 184 | leave 185 | 186 | > (fun (a b . c)) 187 | [0 entry] 188 | ldf [1 fun (a b . c)] 189 | [1 fun (a b . c)] 190 | ldc () 191 | leave 192 | 193 | > (fun (x y) z) 194 | [0 entry] 195 | ldf [1 fun (x y)] 196 | [1 fun (x y)] 197 | ldv z 198 | leave 199 | 200 | > (fun (0)) 201 | fail 202 | 203 | > (macro ()) 204 | [0 entry] 205 | ldm [1 macro ()] 206 | [1 macro ()] 207 | ldc () 208 | 209 | > (macro (x y) x) 210 | [0 entry] 211 | ldm [1 macro (x y)] 212 | [1 macro (x y)] 213 | ldv x 214 | 215 | > (builtin hello) 216 | [0 entry] 217 | ldb hello 218 | 219 | > (builtin "hello") 220 | fail 221 | 222 | > '(1 2 3) 223 | [0 entry] 224 | ldc (1 2 3) 225 | 226 | > (quote a b) 227 | fail 228 | -------------------------------------------------------------------------------- /testsuites/parser: -------------------------------------------------------------------------------- 1 | > foo 2 | foo 3 | 4 | > abc123 5 | abc123 6 | 7 | > foo-bar 8 | foo-bar 9 | 10 | > *foo* 11 | *foo* 12 | 13 | > x 14 | x 15 | 16 | > x1-y2!$%&*+-/:<=>?@^_~ 17 | x1-y2!$%&*+-/:<=>?@^_~ 18 | 19 | > . 20 | fail 21 | 22 | > the-Answer-to-the-Ultimate-Question 23 | the-Answer-to-the-Ultimate-Question 24 | 25 | > 0 26 | 0 27 | 28 | > 1234 29 | 1234 30 | 31 | > 3.5 32 | 3.5 33 | 34 | > +732 35 | 732 36 | 37 | > -42 38 | -42 39 | 40 | > 13e2 41 | 1300 42 | 43 | > 9e+1 44 | 90 45 | 46 | > 125e-1 47 | 12.5 48 | 49 | > "foo" 50 | "foo" 51 | 52 | > "Hello, World!" 53 | "Hello, World!" 54 | 55 | > "( ) . 0 a" 56 | "( ) . 0 a" 57 | 58 | > "foo\nbar" 59 | "foo\nbar" 60 | 61 | > "foo 62 | > bar" 63 | "foo\nbar" 64 | 65 | > "A \" B" 66 | "A \" B" 67 | 68 | > "A\t B" 69 | "A\t\tB" 70 | 71 | > "\\\\" 72 | "\\\\" 73 | 74 | > "hello 75 | fail 76 | 77 | > "world\ 78 | fail 79 | 80 | > "unknown \p escape sequence" 81 | fail 82 | 83 | > () 84 | () 85 | 86 | > [] 87 | () 88 | 89 | > (12) 90 | (12) 91 | 92 | > (12 .) 93 | fail 94 | 95 | > (. 34) 96 | fail 97 | 98 | > (foo . bar) 99 | (foo . bar) 100 | 101 | > (1 2 . 3) 102 | (1 2 . 3) 103 | 104 | > (a b c d) 105 | (a b c d) 106 | 107 | > (foo [bar (baz)]) 108 | (foo (bar (baz))) 109 | 110 | > (#t #f) 111 | (#t #f) 112 | 113 | > 'foo 114 | 'foo 115 | 116 | > '(foo 123) 117 | '(foo 123) 118 | 119 | > `(i ,j ,@(k l)) 120 | `(i ,j ,@(k l)) 121 | 122 | > 123 123 | 123 124 | 125 | > ; hello 126 | > ; world 127 | > () 128 | () 129 | 130 | > (foo ; comment 131 | > bar) ; comment 132 | (foo bar) 133 | 134 | > (this 135 | > is 136 | > the 137 | > last) 138 | (this is the last) 139 | -------------------------------------------------------------------------------- /testsuites/vm: -------------------------------------------------------------------------------- 1 | > 123 2 | 123 3 | 4 | > 'hoge 5 | hoge 6 | 7 | > (begin 123 456 789) 8 | 789 9 | 10 | > foo 11 | fail 12 | 13 | > (def foo "foo") 14 | () 15 | 16 | > foo 17 | "foo" 18 | 19 | > (def foo "bar") 20 | () 21 | 22 | > foo 23 | "bar" 24 | 25 | > (set! foo "baz") 26 | () 27 | 28 | > foo 29 | "baz" 30 | 31 | > (set! hoge "fuga") 32 | fail 33 | 34 | > (fun () 123) 35 | 36 | 37 | > ((fun () 123)) 38 | 123 39 | 40 | > ((fun (a b) a) 12) 41 | fail 42 | 43 | > ((fun (a b) a) 12 34) 44 | 12 45 | 46 | > ((fun (a b) a) 12 34 56) 47 | fail 48 | 49 | > ((fun (a . b) b)) 50 | fail 51 | 52 | > ((fun (a . b) a) 12) 53 | 12 54 | 55 | > ((fun (a . b) b) 12) 56 | () 57 | 58 | > ((fun (a . b) b) 12 34 56) 59 | (34 56) 60 | 61 | > ((fun a a) 12 34) 62 | (12 34) 63 | 64 | > (set! foo #t) 65 | () 66 | > ((fun () (def foo #f))) 67 | () 68 | > foo 69 | #t 70 | 71 | > ((fun () (set! foo #f))) 72 | () 73 | > foo 74 | #f 75 | 76 | > (def _list (fun a a)) 77 | () 78 | > (_list 1 (_list 2 3) 4) 79 | (1 (2 3) 4) 80 | 81 | > (set! foo 0) 82 | () 83 | > (set! foo (_list foo 1)) 84 | () 85 | > foo 86 | (0 1) 87 | 88 | > (begin 89 | > (set! foo 0) 90 | > (set! foo (_list foo 1)) 91 | > (set! foo (_list foo 2)) 92 | > (set! foo (_list foo 3)) 93 | > foo) 94 | (((0 1) 2) 3) 95 | 96 | > (if #t 123 456) 97 | 123 98 | 99 | > (if #f 123 456) 100 | 456 101 | 102 | > (if "anything except #f" 123 456) 103 | 123 104 | 105 | > (if () 123 456) 106 | 123 107 | 108 | > (if #t (def hoge "fuga") (def hoge "fuga")) 109 | () 110 | > hoge 111 | fail 112 | 113 | > (begin 114 | > (set! foo 0) 115 | > (if #t 116 | > (set! foo (_list foo 1)) 117 | > (set! foo (_list foo 2))) 118 | > foo) 119 | (0 1) 120 | 121 | > (begin 122 | > (set! foo 0) 123 | > (if #f 124 | > (set! foo (_list foo 1)) 125 | > (set! foo (_list foo 2))) 126 | > foo) 127 | (0 2) 128 | 129 | > (macro (a b) a) 130 | 131 | 132 | > ((macro (a b) a) 12 34) 133 | fail 134 | 135 | > (def _skip (macro (a . b) b)) 136 | () 137 | > (_skip 12 _list 34 56) 138 | (34 56) 139 | 140 | > (set! foo #t) 141 | () 142 | > (_skip (set! foo #f) _list) 143 | () 144 | > foo 145 | #t 146 | 147 | > (_skip 12 _skip 34 _list 56 78) 148 | (56 78) 149 | 150 | > (_list 12 (_skip 34 _list 56 78)) 151 | (12 (56 78)) 152 | --------------------------------------------------------------------------------