├── lib
    ├── bytecode.ss
    ├── environment.ss
    ├── Makefile
    ├── test1.scm
    ├── additions.scm
    ├── assert.scm
    ├── compile.sh
    ├── test2.scm
    ├── test.scm
    ├── main.scm
    ├── environment.scm
    ├── assembler.scm
    ├── bytecode.scm
    ├── tree-walk.scm
    └── system.lsp
├── src
    ├── print.rs
    ├── state.rs
    ├── assembler.rs
    ├── alloc
    │   ├── rust_data.rs
    │   ├── debug.rs
    │   └── mod.rs
    ├── test.h
    ├── closure.rs
    ├── api
    │   ├── pool.rs
    │   ├── handle.rs
    │   └── mod.rs
    ├── gc.rs
    ├── macros.scm
    ├── ast_interp.rs
    ├── gc.c
    ├── compiler
    │   └── mod.rs
    ├── lib.rs
    ├── interp.c
    ├── string.rs
    ├── symbol.rs
    ├── arith.rs
    ├── bytecode.rs
    ├── interp.rs
    ├── value.rs
    ├── test
    └── read.rs
├── .gitignore
├── Cargo.toml
├── Makefile
├── TODO.txt
├── README.md
├── LICENSE-MIT
├── THIRD-PARTY.txt
└── LICENSE-APACHE


/lib/bytecode.ss:
--------------------------------------------------------------------------------
1 | bytecode.scm


--------------------------------------------------------------------------------
/src/print.rs:
--------------------------------------------------------------------------------
1 | fn print(
2 | 


--------------------------------------------------------------------------------
/lib/environment.ss:
--------------------------------------------------------------------------------
1 | environment.scm


--------------------------------------------------------------------------------
/src/state.rs:
--------------------------------------------------------------------------------
1 | pub struct State;
2 | 


--------------------------------------------------------------------------------
/src/assembler.rs:
--------------------------------------------------------------------------------
1 | pub fn name_to_opcode {
2 | }
3 | 


--------------------------------------------------------------------------------
/src/alloc/rust_data.rs:
--------------------------------------------------------------------------------
1 | pub fn alloc_rustdata_tag() {
2 | 


--------------------------------------------------------------------------------
/src/test.h:
--------------------------------------------------------------------------------
1 | struct odd {
2 |    int a;
3 |    char b[];
4 | };
5 | 


--------------------------------------------------------------------------------
/src/closure.rs:
--------------------------------------------------------------------------------
1 | use value;
2 | use alloc;
3 | use arith;
4 | 
5 | pub fn 
6 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | target
2 | Cargo.lock
3 | 
4 | # Backup files
5 | .#.swp
6 | \#*\#
7 | *~
8 | 


--------------------------------------------------------------------------------
/src/api/pool.rs:
--------------------------------------------------------------------------------
1 | //use std::collections::HashMap;
2 | //type Pool<T> = LinkedList;
3 | 


--------------------------------------------------------------------------------
/src/gc.rs:
--------------------------------------------------------------------------------
1 | //! A simple copying garbage collector.
2 | //!
3 | //! This module implements the GC.
4 | 
5 | 


--------------------------------------------------------------------------------
/lib/Makefile:
--------------------------------------------------------------------------------
1 | all: test
2 | test:
3 | 	exec touch main.scm
4 | 	./compile.sh test1.scm
5 | .PHONY: test all
6 | 


--------------------------------------------------------------------------------
/lib/test1.scm:
--------------------------------------------------------------------------------
1 | (let ((alpha 1)
2 |       (beta #f)
3 |       (gamma 2)
4 |       (γ '())
5 |       (δ 0))
6 |    δ)
7 | 


--------------------------------------------------------------------------------
/lib/additions.scm:
--------------------------------------------------------------------------------
1 | (define (bound? sym) (symbol-bound? #f sym))
2 | (define aset! vector-set!)
3 | (define aref vector-ref)
4 | (define (atom? obj) (not (pair? obj)))
5 | 


--------------------------------------------------------------------------------
/lib/assert.scm:
--------------------------------------------------------------------------------
 1 | ;; -*- scheme -*-
 2 | (library
 3 |    (assert)
 4 |    (export assert)
 5 |    (import)
 6 |    (define-syntax assert
 7 |       (syntax-rules ()
 8 |          ((_ asserted-form msg ...)
 9 |           (or asserted-form
10 |               (error 'assert "assertion failed" 'asserted-form msg ...))))))
11 | 


--------------------------------------------------------------------------------
/src/macros.scm:
--------------------------------------------------------------------------------
1 | (define-syntax my-let
2 |    (syntax-rules ()
3 |       ((_ ((bound' form') (bound form) ...) first-body rest-body ...)
4 |        ((lambda (bound' bound ...)
5 |            first-body rest-body ...) form' form ...))
6 |       ((_ var ((bound' form') (bound form) ...) first-body rest-body ...)
7 |        ((_ var ((bound
8 | 


--------------------------------------------------------------------------------
/lib/compile.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/sh -e
 2 | 
 3 | case $0 in
 4 |     /*) LOADPATH=${0%/*};;
 5 |     */*) LOADPATH=./${0%/*};;
 6 |     *) LOADPATH=.;;
 7 | esac
 8 | 
 9 | run_guile () {
10 |     guile --fresh-auto-compile -L "$LOADPATH/" "$LOADPATH/main.scm" "$@"
11 |     #ikarus --r6rs-script main.scm
12 | }
13 | 
14 | run_guile "$LOADPATH/system.lsp"
15 | 


--------------------------------------------------------------------------------
/src/ast_interp.rs:
--------------------------------------------------------------------------------
 1 | 
 2 | 
 3 | use value;
 4 | use interp;
 5 | use api;
 6 | 
 7 | pub fn ast_eval(s: &mut interp::State) {
 8 |     use value::Tags;
 9 |     match s.heap.stack.len() {
10 |         0 => return,
11 |         depth => if s.heap.stack[depth-1].tag().self_evaluating() {
12 |             return
13 |         } else {
14 |             
15 | 


--------------------------------------------------------------------------------
/Cargo.toml:
--------------------------------------------------------------------------------
 1 | [package]
 2 | name = "rusty_scheme"
 3 | version = "0.1.0"
 4 | authors = ["Demi Marie Obenour <demiobenour@gmail.com>"]
 5 | repository = "https://github.com/DemiMarie/RustyScheme"
 6 | readme = "README.md"
 7 | license = "MIT/Apache 2.0"
 8 | keywords = ["scheme", "interpreter", "scripting"]
 9 | 
10 | [dependencies]
11 | libc = "*"
12 | log = "*"
13 | env_logger = "*"
14 | 
15 | [features]
16 | default = ["memcpy-gc"]
17 | memcpy-gc = []
18 | debug-logging = []
19 | clippy = []
20 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | .PHONY: all test build doc release
 2 | export RUST_BACKTRACE := 0
 3 | export RUST_LOG := rusty_scheme::alloc=debug,rusty_scheme::api=debug,rusty_scheme::read=debug
 4 | export TARGETS := $(TARGETS)
 5 | all: doc
 6 | build:
 7 | 	cargo build -j10
 8 | 	cargo clippy --features=clippy -j10
 9 | 
10 | test: build
11 | 	cargo test  -j10 -- ${TARGETS}
12 | 
13 | release: test
14 | 	cargo build --release -j10
15 | 	cargo test --release -j10
16 | 
17 | doc: release
18 | 	cargo doc -j10
19 | 


--------------------------------------------------------------------------------
/lib/test2.scm:
--------------------------------------------------------------------------------
 1 | (letrec ((cont
 2 |           (lambda (env bco last-compiled-head)
 3 |             (let ((res (read)))
 4 |               (if (eof-object? res)
 5 |                   (cdr list-to-build)
 6 |                   (let ((just-compiled
 7 |                          (cons (compile-form res env bco) (quote ()))))
 8 |                     (set-cdr! last-compiled-head just-compiled)
 9 |                     (set! last-compiled-head just-compiled)))))))
10 |   (cont (env.new) (create-bco) list-to-build))
11 | 


--------------------------------------------------------------------------------
/src/gc.c:
--------------------------------------------------------------------------------
 1 | typedef struct { size_t contents; } Value;
 2 | 
 3 | typedef struct {
 4 |   Value *start;
 5 |   size_t length;
 6 | } Heap;
 7 | 
 8 | void mark_and_collect(Heap *stack, Heap *fromspace, Heap *tospace) {
 9 |   Value *end = tospace->start;
10 | 
11 |   for (Value *current = stack->start;
12 |        ((size_t)current) - ((size_t)stack) < stack->length;) {
13 |     copy(&current, &end);
14 |   }
15 | 
16 |   for (Value *current = tospace->start; (size_t)current < ((size_t)end);) {
17 |     copy(&current, &end);
18 |   }
19 | }
20 | 


--------------------------------------------------------------------------------
/TODO.txt:
--------------------------------------------------------------------------------
 1 | - Near term:
 2 |  - VM:
 3 |   - Embedding API for the VM
 4 |   - Built-in functions
 5 |   - Reader
 6 |   - Printer
 7 |   - Opcodes:
 8 |    - `LoadT`
 9 |    - `LoadF`
10 |    - `Load0`
11 |    - `Load1`
12 |   - Singleton objects
13 |    - `#t`
14 |    - `#f`
15 |    - `()` (the empty list)
16 |  - Bytecode compiler
17 |   - Assembler
18 |   - Fix type errors
19 | 
20 | - Medium term:
21 |  - Documentation for the VM
22 |  - Provide some basic libraries
23 | 
24 | - Long term:
25 |  - JIT compiler
26 |  - Foreign Function Interface
27 | 


--------------------------------------------------------------------------------
/lib/test.scm:
--------------------------------------------------------------------------------
 1 | 
 2 | (define (main)
 3 |    (with-input-from-file (cadr (command-line))
 4 |       (lambda ()
 5 |          (let ((list-to-build (cons #f '())))
 6 |             (let cont ((env (env.new))
 7 |                        (bco (create-bco))
 8 |                        (last-compiled-head list-to-build))
 9 |                (let ((res (read)))
10 |                   (if (eof-object? res)
11 |                       (cdr list-to-build)
12 |                       (let ((just-compiled
13 |                                (cons (compile-form res env bco) '())))
14 |                          (set-cdr! last-compiled-head just-compiled)
15 |                          (set! last-compiled-head just-compiled)))))))))
16 | 


--------------------------------------------------------------------------------
/src/compiler/mod.rs:
--------------------------------------------------------------------------------
 1 | use api;
 2 | 
 3 | pub fn compile_list(vec: &mut Vec<Opcode>, s: &mut api::State)
 4 |                     -> Result<usize, &'static str> {
 5 |     try!(s.dup());
 6 |     let mut length = 1usize;
 7 |     while let Ok(x) = s.car() {
 8 |         try!(compile_form(vec, s));
 9 |         length += 1;
10 |         if (s.marked()) {
11 |             return Err("circular list not allowed")
12 |         }
13 |         s.mark();
14 |         try!(s.cdr());
15 |         try!(s.dup());
16 |     }
17 |     let retval = if s.null() {
18 |         Ok(length)
19 |     } else {
20 |         Err("dotted list not allowed")
21 |     };
22 |     s.drop();
23 |     retval
24 | }
25 | 
26 | pub fn compile_form(vec: &mut Vec<Opcode>, s: &mut api::State)
27 |                     -> Result<usize, &'static str> {
28 |     match s.typeof() {
29 |         Typeof::Pair => {
30 |             try!(s.dup());
31 |             try!(s.car());
32 |             try!(s.cdr());
33 |             match 
34 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # rusty_scheme: a "simple" Scheme interpreter, written in Rust.
 2 | 
 3 | This is a simple Scheme interpreter, written in Rust.  It is intended for extending applications written in Rust, or as an interpreter for general use.
 4 | 
 5 | It is woefully incomplete yet, to the point that it does not even compile, much less run hello world.  Contributions would be greatly appreciated.
 6 | 
 7 | I would love any contributions to be project, and will review any PRs and in all likelyhood will accept them.  I will probably not be able to work much on this project on my own for a while, since college is starting up again. (But I do plan to finish it.)
 8 | 
 9 | # License
10 | 
11 | Licensed under the [MIT license][1] or the [Apache License, Version 2.0][2] at your discretion.  This project may not be copied, modified, or distributed except in accordence with those terms.
12 | 
13 | By submitting contributions, you agree to license anything you contribute under the same license as this project, without any further terms and conditions.
14 | 
15 | [1]: LICENSE-MIT
16 | [2]: LICENSE-APACHE
17 | 


--------------------------------------------------------------------------------
/src/api/handle.rs:
--------------------------------------------------------------------------------
 1 | use std::cell;
 2 | use value;
 3 | use libc;
 4 | pub struct Handle<'a> {
 5 |     index: usize,
 6 |     reference: &'a cell::UnsafeCell<Table>,
 7 | }
 8 | enum InternalHandle<T> {
 9 |     SchemeObject(T),
10 |     AnotherHandle(usize),
11 | }
12 | 
13 | struct Table {
14 |     table: Vec<Handle>,
15 |     first_free: usize,
16 | }
17 | 
18 | impl<'a> Drop for Handle<'a> {
19 |     fn Drop(&mut self) {
20 |         self.reference.
21 | 
22 | impl Index<Handle, Output=T> for Table<T> {
23 |     fn index(&self, index: &Handle) -> &T {
24 |         match self[index.0] {
25 |             SchemeObject(ref x) => x,
26 |             AnotherHandle(n) => panic!("Expected object, found link {:?}", n),
27 |         }
28 |     }
29 | }
30 | 
31 | impl IndexMut<Handle> for Table<T> {
32 |     fn index(&self, index: &Handle) -> &T {
33 |         match self[index.0] {
34 |             SchemeObject(ref mut x) => x,
35 |             AnotherHandle(n) => panic!("Expected object, found link {:?}", n),
36 |         }
37 |     }
38 | }
39 | 
40 | impl Drop for Handle
41 | 
42 | impl Iterator<Item=T> for Table<T> {
43 | 


--------------------------------------------------------------------------------
/LICENSE-MIT:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2016 Demi Marie Obenour
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
 6 | 
 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
 8 | 
 9 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
10 | 


--------------------------------------------------------------------------------
/src/lib.rs:
--------------------------------------------------------------------------------
 1 | #![feature(type_ascription)]
 2 | #![feature(static_recursion)]
 3 | #![allow(dead_code)]
 4 | #![deny(warnings)]
 5 | 
 6 | #[macro_use]
 7 | extern crate log;
 8 | 
 9 | extern crate env_logger;
10 | // macro_rules! debug {
11 | // ($($exp:expr),*) => {
12 | // if cfg!(debug_assertions) {
13 | // println!($($exp),*);
14 | // } else {}
15 | // }
16 | // }
17 | //
18 | macro_rules! bug {
19 |     ($exp: expr) => {
20 |         panic!(concat!("internal error: ", $exp, "
21 |    This is a bug in RustyScheme.  Please report it \
22 |    at https://github.com/DemiMarie/rusty_scheme/issues"))
23 |     };
24 |     ($exp: expr, $($exps: tt)+) => {
25 |         panic!(concat!("internal error: ", $exp, "
26 |    This is a bug in RustyScheme.  Please report it \
27 |    at https://github.com/DemiMarie/rusty_scheme/issues"), $($exps)*)
28 |     }
29 | }
30 | 
31 | #[macro_use]
32 | mod value;
33 | mod state;
34 | mod arith;
35 | mod bytecode;
36 | mod string;
37 | mod alloc;
38 | mod symbol;
39 | mod interp;
40 | mod read;
41 | mod api;
42 | pub use api::*;
43 | pub use bytecode::{Opcode, BCO};
44 | #[cfg(test)]
45 | mod tests {
46 |     #[test]
47 |     fn it_works() {}
48 | }
49 | 


--------------------------------------------------------------------------------
/src/interp.c:
--------------------------------------------------------------------------------
 1 | #include <RustyScheme.h>
 2 | 
 3 | #define OPCODES(OPCODE) \
 4 |    OPCODE(cons) OPCODE(car) OPCODE(cdr) OPCODE(aref) OPCODE(aset) \
 5 |    OPCODE(throw) OPCODE(make_array) OPCODE(apply) OPCODE(call) \
 6 |    OPCODE(tailcall) OPCODE(go) OPCODE(catch) OPCODE(return) \
 7 |    OPCODE(setcar) OPCODE(setcdr) OPCODE(setfield)
 8 | 
 9 | enum OPCODES {
10 | #define OPCODE(x) OPCODE_##x,
11 |    OPCODES(OPCODE)
12 | #undef OPCODE
13 | }
14 | 
15 | #if __GNUC__ >= 3
16 | __attribute__((visibility("hidden")))
17 | #endif
18 | void RustyScheme_execute_opcodes(scheme_State *s) {
19 |    const instruction *pc = s->pc;
20 |    value *const registers = s->registers;
21 | #ifdef HAS_COMPUTED_GOTO
22 | # define OP(x) LABEL_##x:
23 | # define DISPATCH(pc) do { goto labels[(pc++)->opcode]; } while (0)
24 |    static const void * labels[const] = {
25 | # define OPCODE(x) &&LABEL_##x,
26 |       OPCODES(OPCODE)
27 | # undef OPCODE
28 |    };
29 | #else
30 | # define SWITCH_CASE(x) case LABEL_##x: goto GOTO_LABEL_##x;
31 | # define OP(x) GOTO_LABEL_##x:
32 | # define DISPATCH(pc) \
33 |    do { \
34 |       switch ((pc++)->opcode) { \
35 |          OPCODES(SWITCH_CASE) \
36 |          default: __builtin_unreachable(); \
37 |       } \
38 |    } while (0)
39 |    OP(cons):
40 |       uint16_t index1 = pc->op_1;
41 |       uint16_t index2 = pc->op_2;
42 |       uint16_t index3 = pc->op_3;
43 |       value new_cons = allocate_cons(registers[index1], registers[index2]);
44 |       registers[index3] = new_cons;
45 |       DISPATCH(pc)
46 |    OP(setcdr):
47 | 
48 | #endif
49 | 
50 | 


--------------------------------------------------------------------------------
/THIRD-PARTY.txt:
--------------------------------------------------------------------------------
 1 | License of Femptolisp (inspired many data representation choices):
 2 | 
 3 | Copyright (c) 2008 Jeff Bezanson
 4 | 
 5 | All rights reserved.
 6 | 
 7 | Redistribution and use in source and binary forms, with or without
 8 | modification, are permitted provided that the following conditions are met:
 9 | 
10 |     * Redistributions of source code must retain the above copyright notice,
11 |       this list of conditions and the following disclaimer.
12 |     * Redistributions in binary form must reproduce the above copyright notice,
13 |       this list of conditions and the following disclaimer in the documentation
14 |       and/or other materials provided with the distribution.
15 |     * Neither the author nor the names of any contributors may be used to
16 |       endorse or promote products derived from this software without specific
17 |       prior written permission.
18 | 
19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 | 
30 | 


--------------------------------------------------------------------------------
/lib/main.scm:
--------------------------------------------------------------------------------
 1 | ;;; -*- scheme -*-
 2 | #;(import
 3 |    (rnrs)
 4 |    (only (srfi :43) vector-copy)
 5 |    (tree-walk)
 6 |    (environment)
 7 |    (bytecode)
 8 |    (assembler)
 9 |    (only (guile) parameterize)
10 |    (ice-9 pretty-print))
11 | (import (srfi :43))
12 | (include "bytecode.scm")
13 | (include "assembler.scm")
14 | (include "environment.scm")
15 | (include "tree-walk.scm")
16 | (define (bound? sym) (symbol-bound? #f sym))
17 | (define aset! vector-set!)
18 | (define aref vector-ref)
19 | (define (atom? obj) (not (pair? obj)))
20 | (define (void) #t)
21 | (define bco (create-bco))
22 | (define env (env.new))
23 | (define (compile-one-form)
24 |   (let ((res (read)))
25 |     (if (eof-object? res)
26 |         (values)
27 |         (begin
28 |           (compile-toplevel-form res env bco)
29 |           (compile-one-form)))))
30 | (let ((tmp-bco (create-bco))
31 |       (tmp-env (env.new)))
32 |   (emit-constant tmp-bco 'alpha)
33 |   (emit-constant tmp-bco 'alpha)
34 |   (assert (= 1 (bco.consts-len tmp-bco))))
35 | (define (compile-file filename)
36 |   (with-input-from-file filename compile-one-form))
37 | (define (main args)
38 |   (for-each compile-file args)
39 |   (assert (bco? bco))
40 |   (assert (> (bco.len bco) 0))
41 |   (let ((instrs
42 |          (vector-copy (bco.instrs bco)
43 |                       0
44 |                       (bco.len bco)
45 |                       #f)))
46 |     (display "----BEGIN INSTRS----\n")
47 |     (pretty-print instrs)
48 |     (newline)
49 |     
50 |     #;(pretty-print
51 |      (vector
52 |       instrs
53 |       (vector-copy (bco.consts bco)
54 |                       0
55 |                       (bco.consts-len bco)
56 |                       #f)))
57 |     (pretty-print (assemble-bytecode instrs))))
58 |     #;(pretty-print
59 |        (assemble-bytecode
60 |        (vector->list instrs)))
61 | (fluid-set! read-eval? #t)
62 | (pretty-print (main '("system.lsp")))
63 | 


--------------------------------------------------------------------------------
/src/string.rs:
--------------------------------------------------------------------------------
 1 | use std::ptr;
 2 | use std::slice;
 3 | use std::str;
 4 | 
 5 | use api;
 6 | use value;
 7 | use alloc;
 8 | #[repr(C)]
 9 | pub struct SchemeStr {
10 |     header: usize,
11 | 
12 |     /// The type of the object.  Always zero.
13 |     ty: usize,
14 | 
15 |     /// The length in bytes of the following `str`
16 |     len: usize,
17 | }
18 | 
19 | unsafe impl api::SchemeValue for String {
20 |     fn to_value(&self, heap: &mut alloc::Heap) -> value::Value {
21 |         assert!(size_of!(SchemeStr) == 3 * size_of!(usize));
22 |         let object_len: usize = ((size_of!(SchemeStr) + self.len() +
23 |                           0b111) & !0b111)/size_of!(usize);
24 |         let (value_ptr, _) = heap.alloc_raw(object_len,
25 |                                                     value::HeaderTag::RustData);
26 |         let ptr = value_ptr as usize | value::RUST_DATA_TAG;
27 |         unsafe {
28 |             let real_ptr = value_ptr as *mut usize;
29 |             ptr::copy_nonoverlapping(
30 |                 self.as_ptr(),
31 |                 (value_ptr as usize + size_of!(SchemeStr)) as *mut u8,
32 |                 self.len());
33 |             (*real_ptr) = (object_len * size_of!(usize)) |
34 |             value::HeaderTag::RustData as usize;
35 |             (*real_ptr.offset(1)) = 0; // String
36 |             (*real_ptr.offset(2)) = self.len();
37 |         }
38 |         value::Value::new(ptr)
39 |     }
40 |     fn of_value(val: &value::Value) -> Result<Self, String> {
41 |         if val.raw_tag() != value::RUST_DATA_TAG {
42 |             return Err("Value is not a string".to_owned())
43 |         }
44 |         unsafe {
45 |             let scheme_str_ptr = val.as_ptr() as usize;
46 |             if *((scheme_str_ptr + size_of!(usize)) as *const u8) != 0 {
47 |                 return Err("Value is not a string".to_owned())
48 |             }
49 |             let ptr = val.as_ptr() as *const u8;
50 |             Ok(str::from_utf8(
51 |                 slice::from_raw_parts(
52 |                     ptr.offset(size_of!(SchemeStr) as isize),
53 |                     (*(ptr as *const SchemeStr)).len)).expect(
54 |                 "String not valid UTF-8???").to_owned())
55 |         }
56 |     }
57 | }
58 | 


--------------------------------------------------------------------------------
/src/symbol.rs:
--------------------------------------------------------------------------------
 1 | use value;
 2 | use std::collections::HashMap;
 3 | use std::collections::hash_map::Entry;
 4 | use std::cell::{UnsafeCell, Cell};
 5 | use std::rc::Rc;
 6 | 
 7 | pub type StackElement = usize;
 8 | 
 9 | /// This struct stores a symbol.
10 | ///
11 | /// Symbols are never allocated on the GC heap.  They are instead stored
12 | /// on the Rust heap in `SymbolTable` objects, which contain a `HashMap<Rc<str>, Symbol>`
13 | /// that stores the actual symbols.  Each symbol contains a name.
14 | ///
15 | /// Symbols always have tag `value::SYMBOL_TAG`.
16 | #[derive(Debug)]
17 | pub struct Symbol {
18 |     /// The name of the symbol
19 |     name: Rc<String>,
20 | 
21 |     /// A stack used for unspecified purposes in the compiler, such as scope handling.
22 |     /// Must not contain Scheme values.
23 |     pub stack: Vec<StackElement>,
24 | 
25 |     /// The contents
26 |     pub contents: UnsafeCell<value::Value>,
27 | 
28 |     /// Is this alive?
29 |     pub alive: Cell<bool>,
30 | }
31 | 
32 | impl Symbol {
33 |     pub fn name(&self) -> Rc<String> {
34 |         self.name.clone()
35 |     }
36 |     pub fn new(name: Rc<String>) -> Self {
37 |         Symbol {
38 |             contents: UnsafeCell::new(value::Value::new(value::FALSE)),
39 |             name: name,
40 |             stack: vec![],
41 |             alive: Cell::new(false),
42 |         }
43 |     }
44 | }
45 | 
46 | /// A symbol table.
47 | ///
48 | /// The symbol table consists of raw pointers to the strings,
49 | /// which are stored on the GC heap.
50 | ///
51 | /// WARNING: keep this in sync with the GC!  This code does manual relocation
52 | /// of heap pointers!
53 | #[derive(Debug)]
54 | pub struct SymbolTable {
55 |     pub contents: HashMap<Rc<String>, Box<Symbol>>,
56 | }
57 | 
58 | impl SymbolTable {
59 |     pub fn fixup(&mut self) {
60 |         let mut vec = vec![];
61 |         for (i, sym) in &self.contents {
62 |             if sym.alive.get() {
63 |                 sym.alive.set(false)
64 |             } else {
65 |                 vec.push(i.clone())
66 |             }
67 |         }
68 |         // Loop through the dead objects and remove them from the hash table.
69 |         for i in vec {
70 |             match self.contents.entry(i.clone()) {
71 |                 Entry::Occupied(o) => drop(o.remove()),
72 |                 Entry::Vacant(_) => {
73 |                     bug!("SymbolTable::fixup: entry \
74 |                           to be deleted is already vacant")
75 |                 }
76 |             }
77 |         }
78 |     }
79 | }
80 | 
81 | impl Default for SymbolTable {
82 |     fn default() -> Self {
83 |         SymbolTable { contents: HashMap::new() }
84 |     }
85 | }
86 | 


--------------------------------------------------------------------------------
/src/arith.rs:
--------------------------------------------------------------------------------
 1 | use alloc;
 2 | use value::Value;
 3 | pub fn exponential(_: Value, _: Value) -> ! {
 4 |     unimplemented!()
 5 | }
 6 | pub fn slow_add(_alloc: alloc::Heap, _first: &mut Value, _other: &mut Value) -> ! {
 7 |     unimplemented!()
 8 | }
 9 | /// Add two `Value`s, according to Scheme semantics.
10 | ///
11 | /// The cases where both are fixnums or both are flonums is special-cased
12 | /// as a fast path function, which is inlined into the interpreter.  The general case is much slower and put in a seperate function, which is not inlined.
13 | /// function
14 | // #[inline(always)]
15 | pub fn add(_alloc: &mut alloc::Heap, first: &Value, other: &Value) -> Result<Value, String> {
16 |     if first.both_fixnums(other) {
17 |         let res = (first.get() & !1).checked_add(other.get());
18 |         res.ok_or("overflow not yet implemented".to_owned())
19 |            .map(Value::new)
20 |         /*
21 |         if res.contents > first.contents {
22 |             // Overflow!
23 |             value::Bignum::new_from_fixnums(first.contents, other.contents)
24 |         } else {
25 |             Ok(res)
26 |         }*/
27 |     } else if first.flonump() && other.flonump() {
28 |         // Multiply the `f64` values pointed to by the arguments
29 |         //Ok(alloc.alloc_float(unsafe { float_val(first) * float_val(other) }))
30 |         //unimplemented!()
31 |         Err("flonums not yet implemented".to_owned())
32 |     } else {
33 |         // Slow path.
34 |         Err("non-fixnum addition not yet implemented".to_owned())
35 |         //
36 |         //self::slow_add(alloc, first, other)
37 |     }
38 | }
39 | //#[inline(always)]
40 | pub fn subtract(_alloc: &mut alloc::Heap, first: &Value, other: &Value) -> Result<Value, String> {
41 |     if first.both_fixnums(other) {
42 |         let res = (first.get() & !1).checked_sub(other.get());
43 |         res.ok_or("overflow not yet implemented".to_owned())
44 |            .map(Value::new)
45 |     } else if first.flonump() && other.flonump() {
46 |         Err("flonums not yet implemented".to_owned())
47 |     } else {
48 |         Err("non-fixnum addition not yet implemented".to_owned())
49 |     }
50 | }
51 | 
52 | //#[inline(always)]
53 | pub fn multiply(_alloc: &mut alloc::Heap, first: &Value, other: &Value) -> Result<Value, String> {
54 |     if first.both_fixnums(other) {
55 |         let res = (first.get() & !1).checked_mul(other.get());
56 |         res.ok_or("overflow not yet implemented".to_owned())
57 |            .map(Value::new)
58 |     } else if first.flonump() && other.flonump() {
59 |         Err("flonums not yet implemented".to_owned())
60 |     } else {
61 |         Err("non-fixnum addition not yet implemented".to_owned())
62 |     }
63 | }
64 | 
65 | //#[inline(always)]
66 | pub fn divide(_alloc: &mut alloc::Heap, first: &Value, other: &Value) -> Result<Value, String> {
67 |     if first.both_fixnums(other) {
68 |         let (first, other) = (first.get() & !3, other.get() & !3);
69 |         let res = first.checked_div(other);
70 |         res.ok_or("overflow not yet implemented".to_owned())
71 |            .map(Value::new)
72 |     } else if first.flonump() && other.flonump() {
73 |         Err("flonums not yet implemented".to_owned())
74 |     } else {
75 |         Err("non-fixnum addition not yet implemented".to_owned())
76 |     }
77 | }
78 | 


--------------------------------------------------------------------------------
/lib/environment.scm:
--------------------------------------------------------------------------------
  1 | ;;;; -*- scheme -*-
  2 | ;;;; Copyright 2016 Demi Marie Obenour.
  3 | ;;;;
  4 | ;;;; Licensed under the Apache License, Version 2.0 or the MIT license at your
  5 | ;;;; discretion.  This file may not be copied, modified, or distributed except
  6 | ;;;; in accordence with those terms.
  7 | 
  8 | ;;; Scheme environments are implemented as hash tables of linked lists.
  9 | 
 10 | #;(library
 11 | (environment (0))
 12 | (export
 13 |  lookup-environment
 14 |  expression-context?
 15 |  bind-variable
 16 |  bind-arguments
 17 |  unbind-argument
 18 |  env?
 19 |  env.new
 20 |  env.table
 21 |  env.depth
 22 |  env.macros
 23 |  env.set-depth!))
 24 | (import
 25 |  (rnrs)
 26 |  ;;(bytecode)
 27 |  ;;(only (srfi :1) proper-list?)
 28 |  (only (srfi :9) define-record-type)
 29 |  (only (srfi :69) make-hash-table hash-table-ref hash-table-set!
 30 |        hash-table-update!))
 31 | 
 32 | (define-record-type :env
 33 |   (env.raw-make table macros depth)
 34 |   env?
 35 |   (table env.table)
 36 |   (macros env.macros)
 37 |   (depth env.depth env.set-depth!))
 38 | ;; A Scheme environment.
 39 | ;;
 40 | ;; A Scheme environment consists of key-value pairs.  The keys are symbols
 41 | ;; and the values are association lists (of (depth, stack position) pairs).
 42 | (define (env.new)
 43 |   (env.raw-make (make-hash-table) (make-hash-table)0))
 44 | 
 45 | (define (expression-context? env) #f)
 46 | (define (with-bindings env symbols exprs while-bound compile-expr bco)
 47 |   ;;(assert (proper-list? symbols))
 48 |   (assert (= (length symbols) (length exprs)))
 49 |   (let ((table (env.table env)))
 50 |     ;;(assert (hash-table? table))
 51 |     ;;(assert (proper-list? symbols))
 52 |     (let ((old-bindings
 53 |            (map (lambda (symbol)
 54 |                   (hash-table-ref table symbol (lambda ()
 55 |                                                  `((,symbol . global)))))
 56 |                 symbols)
 57 |            ))
 58 |       ;;(emit-bindings bco symbols exprs table compile-expr old-bindings)
 59 |       (while-bound)
 60 |       (map (lambda (symbol binding)
 61 |              (hash-table-set! table symbol binding))
 62 |            symbols old-bindings))))
 63 | 
 64 | (define (bind-arguments symbols env)
 65 |   (let ((nth 0))
 66 |     (define (bind-arguments-internal symbols env)
 67 |       (if (not (null? symbols))
 68 |           (begin
 69 |             (bind-symbol (car symbols) env nth (cons nth 'argument))
 70 |             (set! nth (+ 1 nth))
 71 |             (bind-arguments-internal (cdr symbols) env))))
 72 |     (bind-arguments-internal symbols env)))
 73 | 
 74 | (define (bind-variable symbol env nth)
 75 |   (bind-symbol symbol env nth nth))
 76 | 
 77 | (define (bind-symbol symbol env nth bindee)
 78 |   (let ((table (env.table env)))
 79 |     (hash-table-ref table symbol (lambda()'()))
 80 |     (hash-table-update!
 81 |      table symbol (lambda (plist) (cons bindee plist))
 82 |      (lambda () `((,symbol . global))))
 83 |     (env.set-depth! env (+ 1 nth))))
 84 | 
 85 | (define (unbind-argument symbol env)
 86 |   (assert (env? env))
 87 |   (hash-table-update!
 88 |    (env.table env) symbol
 89 |    (lambda (plist)
 90 |      (assert (and (pair? plist)
 91 |                   "Attempt to unbind a variable that was never bound!"
 92 |                   ))
 93 |      (cdr plist))
 94 |    (lambda ()
 95 |      (assert
 96 |       (and #f "Attempt to unbind a variable that was never bound!")))))
 97 | 
 98 | (define (lookup-environment env symbol bco)
 99 |   (or (symbol? symbol)
100 |       (error 'assert "cannot look up non-symbol" symbol))
101 |   (case symbol
102 |     ;; Built-in functions
103 |     ((apply
104 |       ;; Vector ops
105 |       vector-set! vector-length vector-ref make-vector vector?
106 |       ;; List ops
107 |       set-car! set-cdr! cons car cdr pair?
108 |       ;; Math ops
109 |       + - * / exp)
110 |      (cons symbol 'primitive))
111 |     (else
112 |      (car
113 |       (hash-table-ref (env.table env)
114 |                       symbol
115 |                       (lambda () (list (cons symbol 'global))))))))
116 | 


--------------------------------------------------------------------------------
/src/alloc/debug.rs:
--------------------------------------------------------------------------------
  1 | //! Expensive, debug-mode-only consistency checks on the entire heap.
  2 | 
  3 | use value;
  4 | use value::{Value, HEADER_TAG, Tags};
  5 | use symbol;
  6 | use super::{PAIR, VECTOR, BYTECODE, RUSTDATA};
  7 | 
  8 | /// Consistency checks on the whole heap (in debug mode only) – sloooow.
  9 | pub unsafe fn consistency_check(heap: &[Value]) {
 10 |     if cfg!(debug_assertions) {
 11 |         let mut index = 0;
 12 |         while index < heap.len() {
 13 |             let current = heap[index].clone();
 14 |             let len = current.get() as usize & !HEADER_TAG;
 15 |             assert!(len > 1);
 16 |             index += 1;
 17 |             match current.get() as usize & HEADER_TAG {
 18 |                 PAIR | VECTOR => {
 19 |                     for x in 1..len {
 20 |                         debug_assert_valid_value(heap, index, x, len);
 21 |                         index += 1;
 22 |                     }
 23 |                 }
 24 |                 BYTECODE | RUSTDATA => {
 25 |                     // do nothing, these are not scanned
 26 |                 }
 27 |                 _ => bug!("Strange header {:x}", current.get() as usize),
 28 |             }
 29 |         }
 30 |     }
 31 | }
 32 | 
 33 | /// Assert a value is valid (in debug mode)
 34 | ///
 35 | /// Parameters:
 36 | ///
 37 | /// - `heap`: the current tospace
 38 | /// - `index`: the index into the heap
 39 | unsafe fn debug_assert_valid_value(heap: &[Value], index: usize, x: usize, len: usize) {
 40 |     let current = heap[index].clone();
 41 |     if current.get() < 0xFF {
 42 |         return;
 43 |     }
 44 |     match current.tag() {
 45 |         Tags::Num | Tags::Num2 => {
 46 |             assert!(current.get() & 0b11 == 0);
 47 |         }
 48 |         Tags::Pair => {
 49 |             assert!(current.get() & 0b111 == 0b111);
 50 |             assert_valid_heap_pointer(heap, &current);
 51 |             if (*current.as_ptr()).get() != value::PAIR_HEADER {
 52 |                 bug!("BAD PAIR: header length is \
 53 |                       0x{:x} and not \
 54 |                       0x{:x} at index 0x{:x} into heap and index \
 55 |                       0x{:x} into block",
 56 |                      ((*current.as_ptr()).get()),
 57 |                      value::PAIR_HEADER,
 58 |                      index,
 59 |                      x);
 60 |             }
 61 |             for i in 1..3 {
 62 |                 assert_valid_heap_pointer(heap,
 63 |                                          &*(current.as_ptr().offset(i as isize) as *const Value))
 64 |             }
 65 |         }
 66 |         Tags::Vector => {
 67 |             assert_valid_heap_pointer(heap, &current);
 68 |             for i in 1..len {
 69 |                 assert_valid_heap_pointer(heap, &*current.as_ptr().offset(i as isize))
 70 |             }
 71 |         }
 72 |         Tags::Symbol => {
 73 |             let aligned_size = super::align_word_size(size_of!(symbol::Symbol) /
 74 |                                                       size_of!(usize));
 75 |             assert!(len == aligned_size,
 76 |                     "len = {:x}, aligned_size = {:x}", len, aligned_size);
 77 |             assert_valid_heap_pointer(heap, &current);
 78 |             assert_valid_heap_pointer(heap, &*current.as_ptr().offset(1))
 79 |         }
 80 |         Tags::RustData => /* not scanned */ {}
 81 |         Tags::Function|Tags::RustFunc => panic!("not yet implemented: tag {:?} of {:x}", current.tag(), current.get())
 82 |     }
 83 | }
 84 | 
 85 | pub fn assert_valid_heap_pointer(vec: &[Value], i: &Value) {
 86 |     if cfg!(debug_assertions) {
 87 |         let lower_limit = vec.as_ptr() as usize;
 88 |         let upper_limit = lower_limit + vec.len() * size_of!(usize);
 89 |         let contents = i.contents.get();
 90 |         let untagged = contents & !0b111;
 91 |         if !(contents & 0b11 == 0 || contents < 0xFF || contents & 0b111 == 0b110 ||
 92 |              (untagged >= lower_limit && untagged < upper_limit)) {
 93 |             let contents = contents;
 94 |             bug!("argument not fixnum or pointing into \
 95 |                   tospace: {:x}",
 96 |                  contents)
 97 |         }
 98 |     }
 99 | }
100 | 


--------------------------------------------------------------------------------
/lib/assembler.scm:
--------------------------------------------------------------------------------
  1 | (define instruction-table (make-hash-table))
  2 | (define instructions
  3 |   '(car cdr set-car! set-cdr! pair?
  4 |         + - * / exp
  5 |         vector vector-set! vector-ref vector? vector-length
  6 |         apply call tail-call return closure
  7 |         set
  8 |         load-constant load-argument load-environment load-global
  9 |         load-f load-t load-nil load-0 load-1
 10 |         store-environment store-argument store-global
 11 |         branch jump closure-extra bind-variable))
 12 | (let ((index 0))
 13 |   (for-each
 14 |    (lambda (x)
 15 |      (hash-table-set! instruction-table x index)
 16 |      (set! index (+ 1 index)))
 17 |    instructions))
 18 | 
 19 | ;;; Assembles instruction `opcode` to binary port `port`.
 20 | ;;; Returns the new offset relative to the start of the BCO.
 21 | (define (assemble-instr port opcode offset label-table)
 22 |   #;(pretty-print opcode)
 23 |   #;(newline)
 24 |   (define (put-u24 opvector)
 25 |     (map (lambda (x)
 26 |            (put-u8 port (logand x 255))
 27 |            (put-u8 port (logand (ash x -8) 255))
 28 |            (put-u8 port (logand (ash x -16) 255)))
 29 |          opvector))
 30 |   (assert (pair? opcode))
 31 |   (if (not (eq? (car opcode) 'label))
 32 |       (put-u8 port (hash-table-ref instruction-table (car opcode))))
 33 |   ;;(assert #f)
 34 |   (let ((op-vector
 35 |          (case (car opcode)
 36 |            ((load-f load-t load-nil load-0 load-1
 37 |                     cons car cdr
 38 |                     vector-ref vector-set!)
 39 |             '(0))
 40 |            ((load-global load-constant load-argument load-environment
 41 |                          bind-variable)
 42 |             (cdr opcode))
 43 |            ((closure jump branch)
 44 |             (let* ((opcode-list (cdr opcode))
 45 |                    (label-num
 46 |                     (begin
 47 |                       (car opcode-list)))
 48 |                    (label-list
 49 |                     (or (hash-table-ref label-table label-num (lambda ()
 50 |                                                                 (list #f)))))
 51 |                    (tail (cdr label-list)))
 52 |               (set-cdr! label-list (cons label-num tail))
 53 |               (case (car opcode)
 54 |                 ((closure)
 55 |                  (let ((fixed-args (car opcode-list)))
 56 |                    (assert (<= fixed-args (ash 1 23)))
 57 |                    (let
 58 |                        ((new-list
 59 |                          (list
 60 |                           (logior fixed-args
 61 |                                   (ash (if (cadr opcode-list) 0 1) 24)))))
 62 | 
 63 |                      (put-u24 new-list)
 64 |                      #f)
 65 |                    (put-u8 port
 66 |                            (hash-table-ref instruction-table 'closure-extra))
 67 |                    (cddr opcode-list)))
 68 |                 ((branch jump) opcode-list)
 69 |                 (else (assert #f)))))
 70 |            ((label)
 71 |             ;; Mark up a label
 72 |             (let* ((label-num (cadr opcode))
 73 |                    (label-list
 74 |                     (or (hash-table-ref label-table label-num
 75 |                                         (lambda () (list #f))))))
 76 |               (assert (not (car label-list)))
 77 |               (set-car! label-list offset)
 78 |               '()))
 79 |            (else
 80 |             ;; Can't happen
 81 |             (assert (not "Internal error: assembling invalid opcode"))))))
 82 |     (put-u24 op-vector))
 83 |    (if (eq? (car opcode) 'label)
 84 |        (+ offset 4)
 85 |        offset))
 86 | 
 87 | (define (fixup-offsets bytevec bco-table)
 88 |   (hash-for-each
 89 |    (lambda (key value)
 90 |      (let ((target (car value))
 91 |            (locations (cdr value)))
 92 |        (for-each
 93 |         (lambda (offset)
 94 |           (bytevector-uint-set! bytevec offset target (endianness little) 3))
 95 |         locations)))
 96 |    bco-table))
 97 | 
 98 | (define (assemble-bytecode bco)
 99 |   (let ((table (make-hash-table)))
100 |     (let-values (((port to-bytevector)
101 |                   (open-bytevector-output-port)))
102 | 
103 |       (define (assemble index offset instr)
104 |         (assert (integer? index))
105 |         (assert (integer? offset))
106 |         (pretty-print index)
107 |         (newline)
108 |         (pretty-print offset)
109 |         (newline)
110 |         (pretty-print instr)
111 |         (newline)
112 |         (assemble-instr port instr offset table))
113 |       #;(define (fold kons knil arg)
114 |         (if (null? arg)
115 |           knil
116 |           (begin
117 |             (fold (kons (car arg) knil) (cdr arg)))))
118 |       (vector-fold assemble 0 bco)
119 |       (to-bytevector))))
120 | 


--------------------------------------------------------------------------------
/lib/bytecode.scm:
--------------------------------------------------------------------------------
  1 | ;;;; bytecode.scm – bytecode objects and bytecode generation
  2 | ;;;
  3 | ;;; This library defines the type of bytecode objects.  It also defines
  4 | ;;; operations for appending bytecodes.
  5 | 
  6 | (import
  7 |  (rnrs)
  8 |  (only (srfi :1) proper-list?)
  9 |  (srfi :9)
 10 |  (only (srfi :43) vector-copy)
 11 |  (only (srfi :69) make-hash-table hash-table-ref hash-table-set!))
 12 | 
 13 | (define-record-type :bco
 14 |   (make-bco len instrs consts consts-len stack-depth memo counter)
 15 |   bco?
 16 |   (len bco.len len-set!)
 17 |   (instrs bco.instrs instrs-set!)
 18 |   (consts bco.consts consts-set!)
 19 |   (consts-len bco.consts-len consts-len-set!)
 20 |   (stack-depth stack-depth stack-depth-set!)
 21 |   (memo memo)
 22 |   (counter counter counter-set!))
 23 | 
 24 | (define (create-bco)
 25 |   (make-bco 0 '#() '#(#f) 0 0 (make-hash-table) 0))
 26 | 
 27 | ;; Add `object` to the constant vector of `bco`.
 28 | ;; Returns the index of `object` in the constant vector of `bco`.
 29 | ;; `object` must not be modified afterwords.
 30 | (define (add-to-constant-vector bco object)
 31 |   (assert (not (procedure? object)))
 32 |   (let ((constants (bco.consts bco))
 33 |         (bco-consts-len (bco.consts-len bco)))
 34 |     (assert (fixnum? bco-consts-len))
 35 |     (let ((capacity (vector-length constants)))
 36 |       (vector-set!
 37 |        (if (= bco-consts-len capacity)
 38 |            (let ((new-vector
 39 |                   (vector-copy constants
 40 |                                0
 41 |                                (+ 3 (* 2 capacity)) #f)))
 42 |              (consts-set! bco new-vector)
 43 |              new-vector)
 44 |            constants)
 45 |        bco-consts-len object)
 46 |       (consts-len-set! bco (+ 1 bco-consts-len))
 47 |       bco-consts-len)))
 48 | 
 49 | (define (emit bco . opcode)
 50 |   (assert (bco? bco))
 51 |   (let ((bytecode (bco.instrs bco))
 52 |         (bco-len (bco.len bco)))
 53 |     (let ((capacity (vector-length bytecode)))
 54 |       (vector-set!
 55 |        (cond
 56 |         ((= bco-len capacity)
 57 |          (let ((new-vector (vector-copy bytecode 0 (+ 3 (* 2 bco-len)) #f)))
 58 |            (instrs-set! bco new-vector)
 59 |            new-vector))
 60 |         ((< bco-len capacity)
 61 |          bytecode)
 62 |         (else
 63 |          (assert #f)))
 64 |        bco-len opcode)
 65 |       (len-set! bco (+ 1 bco-len))
 66 |       bco-len)))
 67 | 
 68 | (define (emit-stack-reset bco depth)
 69 |   (emit bco 'stack-reset depth)
 70 |   (stack-depth-set! bco depth))
 71 | 
 72 | (define (emit-load bco arg)
 73 |   (if (pair? arg)
 74 |       (case (cdr arg)
 75 |         ((argument) (emit bco 'load-argument (car arg)))
 76 |         ((global primitive) (emit bco 'load-global (car arg)))
 77 |         ((()) (emit bco 'load-environment (car arg)))
 78 |         (else (error 'assert "bad cdr of arg to be loaded" arg)))
 79 |       (emit bco 'load-environment arg)))
 80 | 
 81 | (define (emit-global bco symbol)
 82 |   (emit bco 'global-load symbol)
 83 |   (let ((new-depth (+ 1 (stack-depth bco))))
 84 |     (stack-depth-set! bco new-depth)
 85 |     new-depth))
 86 | 
 87 | ;; Emit bindings.
 88 | ;; Args: `bco` = bytecode object, `variables` = variables being bound
 89 | ;; `env` = environment
 90 | (define (emit-bindings bco variables expressions env compile-form old-val)
 91 |   (assert (proper-list? variables))
 92 |   (assert (proper-list? expressions))
 93 |   (assert (= (length variables) (length expressions)))
 94 |   (let ((depth (stack-depth bco)))
 95 |     (for-each
 96 |      (lambda (var expr old-val)
 97 |        (compile-form expr)
 98 |        (if (> (stack-depth bco) depth)
 99 |            (emit bco 'adjust-stack (- (stack-depth bco) depth)))
100 |        (set! depth (+ 1 depth))
101 |        (stack-depth-set! bco depth)
102 |        (hash-table-set! env var (cons depth old-val)))
103 |      variables expressions old-val)
104 |     depth))
105 | 
106 | (define (emit-variable-reference bco stack-position)
107 |   (assert (bco? bco))
108 |   (let ((new-stack-depth (+ 1 (stack-depth bco))))
109 |     (stack-depth-set! bco new-stack-depth)
110 |     (cond
111 |      ((symbol? stack-position)
112 |       (emit bco 'global-load stack-position))
113 |      ((fixnum? stack-position)
114 |       (emit bco 'load stack-position))
115 |      (else (assert #f)))))
116 | 
117 | (define (emit-constant bco object)
118 |   (case object
119 |     ((#f) (emit bco 'load-f))
120 |     ((#t) (emit bco 'load-t))
121 |     ((0)  (emit bco 'load-0))
122 |     ((1)  (emit bco 'load-1))
123 |     (else
124 |      (if (null? object)
125 |          (begin
126 |            (emit bco 'load-nil))
127 |          ;; Memoize the objects using the bytecode object's memo table
128 |          (let ((index (hash-table-ref (memo bco) object (lambda () #f))))
129 |            (emit bco
130 |                  'load-constant-index
131 |                  (if index
132 |                      index
133 |                      (begin
134 |                        (add-to-constant-vector bco object)
135 |                        (let ((len (bco.consts-len bco)))
136 |                          (hash-table-set! (memo bco) object len)
137 |                          len)))))))))
138 | 
139 | (define (emit-set! bco stack-position)
140 |   (cond
141 |    ((symbol? stack-position)
142 |     (emit bco 'global-load stack-position))
143 |    ((fixnum? stack-position)
144 |     (emit bco 'store-environment stack-position))
145 |    ((pair? stack-position)
146 |     (case (cdr stack-position)
147 |       ((argument)
148 |        (emit bco 'store-argument (car stack-position)))
149 |       ((global)
150 |        (emit bco 'store-global (car stack-position)))
151 |       (else (assert #f))))
152 |    (else
153 |     (error 'assert "invalid stack position" stack-position))))
154 | 
155 | (define (emit-lambda-definition bco variadic? fixed-args body)
156 |   (let ((stack-position (stack-depth bco))
157 |         (label-start (incr-counter bco))
158 |         (label-end (incr-counter bco)))
159 |     (emit bco 'closure fixed-args variadic? label-end)
160 |     (body)
161 |     (emit bco 'label label-end)))
162 | 
163 | (define (incr-counter bco)
164 |   (let ((old-val (counter bco)))
165 |     (counter-set! bco (+ 1 old-val))
166 |     old-val))
167 | 
168 | ;; Emit a jump.
169 | (define (emit-jump bco condition yes no)
170 |   (let ((stack-position (+ 1 (stack-depth bco)))
171 |         (label-true (incr-counter bco))
172 |         (label-false (incr-counter bco)))
173 |     (condition)
174 |     (emit bco 'branch label-true)
175 |     (no)
176 |     (emit bco 'jump label-false)
177 |     (emit bco 'label label-true)
178 |     (yes)
179 |     (emit bco 'label label-false)))
180 | ;;; Local Variables:
181 | ;;; mode: scheme
182 | ;;; End:
183 | 


--------------------------------------------------------------------------------
/src/bytecode.rs:
--------------------------------------------------------------------------------
  1 | use std::ptr;
  2 | use value;
  3 | use alloc;
  4 | use std::cell;
  5 | 
  6 | /// A bytecode object.  Consists of a header, the length of the bytecodes,
  7 | /// the actual bytecodes, and finally the constants vector (not actually part
  8 | /// of the BCO, but always allocated after it).
  9 | pub struct BCO {
 10 |     /// The standard header object
 11 |     header: usize,
 12 | 
 13 |     /// The length of the bytecodes
 14 |     bytecode_length: usize,
 15 | 
 16 |     /// Pointer to the constants vector
 17 |     constants_vector: cell::UnsafeCell<value::Value>,
 18 | }
 19 | 
 20 | pub fn get_constants_vector(bco: &BCO) -> &cell::UnsafeCell<value::Value> {
 21 |     &bco.constants_vector
 22 | }
 23 | 
 24 | /// The opcodes
 25 | #[repr(u8)]
 26 | #[derive(Copy, Clone, Debug)]
 27 | pub enum Opcode {
 28 |     /// Implements `cons`.  `src` is the stack index of the source,
 29 |     /// `src2` is the stack index of the destination.  `dst` must be 0, 1, or 2
 30 |     /// and refers to the number of words to pop off of the stack.
 31 |     /// Pushes the new pair onto the stack.
 32 |     Cons,
 33 | 
 34 |     /// Implements `car`.  `src` is the stack depth of the pair to take the `car`
 35 |     /// of.
 36 |     Car,
 37 | 
 38 |     /// `cdr`
 39 |     Cdr,
 40 | 
 41 |     /// `set-car!`
 42 |     SetCar,
 43 | 
 44 |     /// `set-cdr!`
 45 |     SetCdr,
 46 | 
 47 |     /// `pair?`
 48 |     IsPair,
 49 | 
 50 |     /// Addition
 51 |     Add,
 52 | 
 53 |     /// Subtraction
 54 |     Subtract,
 55 | 
 56 |     /// Multiplication
 57 |     Multiply,
 58 | 
 59 |     /// Division
 60 |     Divide,
 61 | 
 62 |     /// Exponentiation
 63 |     Power,
 64 | 
 65 |     /// Create an array
 66 |     MakeArray,
 67 | 
 68 |     /// Store to an array
 69 |     SetArray,
 70 | 
 71 |     /// Load from an array
 72 |     GetArray,
 73 | 
 74 |     /// Check for vector
 75 |     IsArray,
 76 | 
 77 |     /// Length of vector
 78 |     ArrayLen,
 79 | 
 80 |     /// Function call
 81 |     Call,
 82 | 
 83 |     /// Tail call
 84 |     TailCall,
 85 | 
 86 |     /// Return from a function
 87 |     Return,
 88 | 
 89 |     /// Create a closure
 90 |     Closure,
 91 | 
 92 |     /// Mutation of stack slots
 93 |     Set,
 94 | 
 95 |     /// Load from constant vector
 96 |     LoadConstant,
 97 | 
 98 |     /// Load from environment
 99 |     LoadEnvironment,
100 | 
101 |     /// Load from argument
102 |     LoadArgument,
103 | 
104 |     /// Load from global
105 |     LoadGlobal,
106 | 
107 |     /// Load `#f`
108 |     LoadFalse,
109 | 
110 |     /// Load `#t`
111 |     LoadTrue,
112 | 
113 |     /// Load the empty list
114 |     LoadNil,
115 | 
116 |     /// Store to environment.  `src` is the stack index of the source.
117 |     /// `dst` is the stack index of the destination.
118 |     StoreEnvironment,
119 | 
120 |     /// Store to argument.  `src` is the index of the argument.
121 |     StoreArgument,
122 | 
123 |     /// Store to global.  `src` is the index of the global in the constants
124 |     /// vector.
125 |     StoreGlobal,
126 | }
127 | 
128 | #[derive(Copy, Clone, Debug)]
129 | pub struct Bytecode {
130 |     pub opcode: Opcode,
131 |     pub src: u8,
132 |     pub src2: u8,
133 |     pub dst: u8,
134 | }
135 | 
136 | pub enum BadByteCode {
137 |     StackUnderflow {
138 |         index: usize,
139 |         depth: usize,
140 |         min: usize,
141 |     },
142 |     EnvOutOfRange {
143 |         index: usize,
144 |         required_length: usize,
145 |         actual_length: usize,
146 |     },
147 | }
148 | 
149 | pub fn allocate_bytecode(obj: &[u8], heap: &mut alloc::Heap) {
150 |     use value::HeaderTag;
151 |     let (val, _) = heap.alloc_raw((size_of!(BCO) + obj.len() + (size_of!(usize) - 1)) /
152 |                                   size_of!(value::Value),
153 |                                   HeaderTag::Bytecode);
154 |     let bco_obj = val as *mut BCO;
155 |     let consts_vector = heap.stack.pop().unwrap();
156 |     heap.stack.push(value::Value::new(val as usize | value::RUST_DATA_TAG));
157 |     unsafe {
158 |         (*bco_obj).bytecode_length = obj.len();
159 |         (*(*bco_obj).constants_vector.get()) = consts_vector;
160 |         ptr::copy_nonoverlapping(obj.as_ptr(),
161 |                                  (val as *mut u8).offset(size_of!(BCO) as isize),
162 |                                  obj.len())
163 |     }
164 | }
165 | 
166 | pub enum SchemeResult {
167 |     BadBytecode(BadByteCode),
168 | }
169 | #[cfg(none)]
170 | pub fn verify_bytecodes(b: &[Bytecode],
171 |                         argcount: u16,
172 |                         is_vararg: bool,
173 |                         environment_length: usize)
174 |                         -> Result<(), BadByteCode> {
175 |     let argcount: usize = argcount.into();
176 |     let mut i = 0;
177 |     let mut max_stack = 0;
178 |     let mut current_depth: usize = 0;
179 |     let mut current_stack: Vec<usize> = vec![];
180 |     let iter = b.iter();
181 | 
182 |     macro_rules! check_stack {
183 |         ($min: expr) => (if current_depth <= $exp {
184 |             return Err(BadByteCode::StackUnderflow { index: i - 1,
185 |                                                      depth: current_depth,
186 |                                                      min: $min, })
187 |         } else {})
188 |     }
189 |     macro_rules! check_argument {
190 |         ($min: expr) => (if argcount <= $expr {
191 |             return Err(BadByteCode::StackUnderflow { index: i - 1,
192 |                                                      depth: current_depth,
193 |                                                      min: $min, })
194 |         } else {})
195 |     }
196 |     macro_rules! check_env {
197 |         ($min: expr) => (if environment_length <= $expr {
198 |             return Err(BadByteCode::EnvOutOfRange { index: i - 1,
199 |                                                     required_length: $expr + 1,
200 |                                                     actual_length:
201 |                                                     environment_length,
202 |             })
203 |         })
204 |     }
205 |     while let Some(opcode) = iter.next() {
206 |         i += 1;
207 |         match try!(byte_to_opcode(opcode)) {
208 |             Opcode::Cons => {
209 |                 check_stack!(2);
210 |                 current_depth -= 1;
211 |             }
212 |             Opcode::Car | Opcode::Cdr => {
213 |                 check_stack!(1);
214 |             }
215 |             Opcode::SetCar | Opcode::SetCdr => {
216 |                 check_stack!(2);
217 |             }
218 |             Opcode::IsPair => {
219 |                 check_stack!(1);
220 |             }
221 |             Opcode::PushTrue | Opcode::PushFalse | Opcode::PushNil => {
222 |                 current_depth += 1;
223 |             }
224 |             Opcode::LoadGlobal | Opcode::LoadConstant => {
225 |                 check_env!(src);
226 |                 current_depth += 1;
227 |             }
228 |             Opcode::LoadArgument => {
229 |                 check_argument!(src);
230 |                 current_depth += 1
231 |             }
232 |             Opcode::StoreArgument => {
233 |                 check_argument!(src);
234 |                 current_depth += 1
235 |             }
236 |             Opcode::LoadEnvironment => {
237 |                 check_stack!(src);
238 |                 current_depth += 1;
239 |             }
240 |             Opcode::ArraySet => {
241 |                 check_stack!(2);
242 |                 current_depth -= 1;
243 |             }
244 |             Opcode::ArrayGet => {
245 |                 check_stack!(2);
246 |             }
247 |             Opcode::IsArray => {
248 |                 check_stack!(1);
249 |             }
250 |             Opcode::Vector => try!(iter.next().ok_or(BadByteCode::EOF)).into(),
251 |         }
252 |     }
253 | }
254 | 


--------------------------------------------------------------------------------
/LICENSE-APACHE:
--------------------------------------------------------------------------------
  1 | 
  2 |                                  Apache License
  3 |                            Version 2.0, January 2004
  4 |                         http://www.apache.org/licenses/
  5 | 
  6 |    TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
  7 | 
  8 |    1. Definitions.
  9 | 
 10 |       "License" shall mean the terms and conditions for use, reproduction,
 11 |       and distribution as defined by Sections 1 through 9 of this document.
 12 | 
 13 |       "Licensor" shall mean the copyright owner or entity authorized by
 14 |       the copyright owner that is granting the License.
 15 | 
 16 |       "Legal Entity" shall mean the union of the acting entity and all
 17 |       other entities that control, are controlled by, or are under common
 18 |       control with that entity. For the purposes of this definition,
 19 |       "control" means (i) the power, direct or indirect, to cause the
 20 |       direction or management of such entity, whether by contract or
 21 |       otherwise, or (ii) ownership of fifty percent (50%) or more of the
 22 |       outstanding shares, or (iii) beneficial ownership of such entity.
 23 | 
 24 |       "You" (or "Your") shall mean an individual or Legal Entity
 25 |       exercising permissions granted by this License.
 26 | 
 27 |       "Source" form shall mean the preferred form for making modifications,
 28 |       including but not limited to software source code, documentation
 29 |       source, and configuration files.
 30 | 
 31 |       "Object" form shall mean any form resulting from mechanical
 32 |       transformation or translation of a Source form, including but
 33 |       not limited to compiled object code, generated documentation,
 34 |       and conversions to other media types.
 35 | 
 36 |       "Work" shall mean the work of authorship, whether in Source or
 37 |       Object form, made available under the License, as indicated by a
 38 |       copyright notice that is included in or attached to the work
 39 |       (an example is provided in the Appendix below).
 40 | 
 41 |       "Derivative Works" shall mean any work, whether in Source or Object
 42 |       form, that is based on (or derived from) the Work and for which the
 43 |       editorial revisions, annotations, elaborations, or other modifications
 44 |       represent, as a whole, an original work of authorship. For the purposes
 45 |       of this License, Derivative Works shall not include works that remain
 46 |       separable from, or merely link (or bind by name) to the interfaces of,
 47 |       the Work and Derivative Works thereof.
 48 | 
 49 |       "Contribution" shall mean any work of authorship, including
 50 |       the original version of the Work and any modifications or additions
 51 |       to that Work or Derivative Works thereof, that is intentionally
 52 |       submitted to Licensor for inclusion in the Work by the copyright owner
 53 |       or by an individual or Legal Entity authorized to submit on behalf of
 54 |       the copyright owner. For the purposes of this definition, "submitted"
 55 |       means any form of electronic, verbal, or written communication sent
 56 |       to the Licensor or its representatives, including but not limited to
 57 |       communication on electronic mailing lists, source code control systems,
 58 |       and issue tracking systems that are managed by, or on behalf of, the
 59 |       Licensor for the purpose of discussing and improving the Work, but
 60 |       excluding communication that is conspicuously marked or otherwise
 61 |       designated in writing by the copyright owner as "Not a Contribution."
 62 | 
 63 |       "Contributor" shall mean Licensor and any individual or Legal Entity
 64 |       on behalf of whom a Contribution has been received by Licensor and
 65 |       subsequently incorporated within the Work.
 66 | 
 67 |    2. Grant of Copyright License. Subject to the terms and conditions of
 68 |       this License, each Contributor hereby grants to You a perpetual,
 69 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 70 |       copyright license to reproduce, prepare Derivative Works of,
 71 |       publicly display, publicly perform, sublicense, and distribute the
 72 |       Work and such Derivative Works in Source or Object form.
 73 | 
 74 |    3. Grant of Patent License. Subject to the terms and conditions of
 75 |       this License, each Contributor hereby grants to You a perpetual,
 76 |       worldwide, non-exclusive, no-charge, royalty-free, irrevocable
 77 |       (except as stated in this section) patent license to make, have made,
 78 |       use, offer to sell, sell, import, and otherwise transfer the Work,
 79 |       where such license applies only to those patent claims licensable
 80 |       by such Contributor that are necessarily infringed by their
 81 |       Contribution(s) alone or by combination of their Contribution(s)
 82 |       with the Work to which such Contribution(s) was submitted. If You
 83 |       institute patent litigation against any entity (including a
 84 |       cross-claim or counterclaim in a lawsuit) alleging that the Work
 85 |       or a Contribution incorporated within the Work constitutes direct
 86 |       or contributory patent infringement, then any patent licenses
 87 |       granted to You under this License for that Work shall terminate
 88 |       as of the date such litigation is filed.
 89 | 
 90 |    4. Redistribution. You may reproduce and distribute copies of the
 91 |       Work or Derivative Works thereof in any medium, with or without
 92 |       modifications, and in Source or Object form, provided that You
 93 |       meet the following conditions:
 94 | 
 95 |       (a) You must give any other recipients of the Work or
 96 |           Derivative Works a copy of this License; and
 97 | 
 98 |       (b) You must cause any modified files to carry prominent notices
 99 |           stating that You changed the files; and
100 | 
101 |       (c) You must retain, in the Source form of any Derivative Works
102 |           that You distribute, all copyright, patent, trademark, and
103 |           attribution notices from the Source form of the Work,
104 |           excluding those notices that do not pertain to any part of
105 |           the Derivative Works; and
106 | 
107 |       (d) If the Work includes a "NOTICE" text file as part of its
108 |           distribution, then any Derivative Works that You distribute must
109 |           include a readable copy of the attribution notices contained
110 |           within such NOTICE file, excluding those notices that do not
111 |           pertain to any part of the Derivative Works, in at least one
112 |           of the following places: within a NOTICE text file distributed
113 |           as part of the Derivative Works; within the Source form or
114 |           documentation, if provided along with the Derivative Works; or,
115 |           within a display generated by the Derivative Works, if and
116 |           wherever such third-party notices normally appear. The contents
117 |           of the NOTICE file are for informational purposes only and
118 |           do not modify the License. You may add Your own attribution
119 |           notices within Derivative Works that You distribute, alongside
120 |           or as an addendum to the NOTICE text from the Work, provided
121 |           that such additional attribution notices cannot be construed
122 |           as modifying the License.
123 | 
124 |       You may add Your own copyright statement to Your modifications and
125 |       may provide additional or different license terms and conditions
126 |       for use, reproduction, or distribution of Your modifications, or
127 |       for any such Derivative Works as a whole, provided Your use,
128 |       reproduction, and distribution of the Work otherwise complies with
129 |       the conditions stated in this License.
130 | 
131 |    5. Submission of Contributions. Unless You explicitly state otherwise,
132 |       any Contribution intentionally submitted for inclusion in the Work
133 |       by You to the Licensor shall be under the terms and conditions of
134 |       this License, without any additional terms or conditions.
135 |       Notwithstanding the above, nothing herein shall supersede or modify
136 |       the terms of any separate license agreement you may have executed
137 |       with Licensor regarding such Contributions.
138 | 
139 |    6. Trademarks. This License does not grant permission to use the trade
140 |       names, trademarks, service marks, or product names of the Licensor,
141 |       except as required for reasonable and customary use in describing the
142 |       origin of the Work and reproducing the content of the NOTICE file.
143 | 
144 |    7. Disclaimer of Warranty. Unless required by applicable law or
145 |       agreed to in writing, Licensor provides the Work (and each
146 |       Contributor provides its Contributions) on an "AS IS" BASIS,
147 |       WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
148 |       implied, including, without limitation, any warranties or conditions
149 |       of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
150 |       PARTICULAR PURPOSE. You are solely responsible for determining the
151 |       appropriateness of using or redistributing the Work and assume any
152 |       risks associated with Your exercise of permissions under this License.
153 | 
154 |    8. Limitation of Liability. In no event and under no legal theory,
155 |       whether in tort (including negligence), contract, or otherwise,
156 |       unless required by applicable law (such as deliberate and grossly
157 |       negligent acts) or agreed to in writing, shall any Contributor be
158 |       liable to You for damages, including any direct, indirect, special,
159 |       incidental, or consequential damages of any character arising as a
160 |       result of this License or out of the use or inability to use the
161 |       Work (including but not limited to damages for loss of goodwill,
162 |       work stoppage, computer failure or malfunction, or any and all
163 |       other commercial damages or losses), even if such Contributor
164 |       has been advised of the possibility of such damages.
165 | 
166 |    9. Accepting Warranty or Additional Liability. While redistributing
167 |       the Work or Derivative Works thereof, You may choose to offer,
168 |       and charge a fee for, acceptance of support, warranty, indemnity,
169 |       or other liability obligations and/or rights consistent with this
170 |       License. However, in accepting such obligations, You may act only
171 |       on Your own behalf and on Your sole responsibility, not on behalf
172 |       of any other Contributor, and only if You agree to indemnify,
173 |       defend, and hold each Contributor harmless for any liability
174 |       incurred by, or claims asserted against, such Contributor by reason
175 |       of your accepting any such warranty or additional liability.
176 | 
177 |    END OF TERMS AND CONDITIONS
178 | 
179 |    APPENDIX: How to apply the Apache License to your work.
180 | 
181 |       To apply the Apache License to your work, attach the following
182 |       boilerplate notice, with the fields enclosed by brackets "[]"
183 |       replaced with your own identifying information. (Don't include
184 |       the brackets!)  The text should be enclosed in the appropriate
185 |       comment syntax for the file format. We also recommend that a
186 |       file or class name and description of purpose be included on the
187 |       same "printed page" as the copyright notice for easier
188 |       identification within third-party archives.
189 | 
190 |    Copyright [yyyy] [name of copyright owner]
191 | 
192 |    Licensed under the Apache License, Version 2.0 (the "License");
193 |    you may not use this file except in compliance with the License.
194 |    You may obtain a copy of the License at
195 | 
196 |        http://www.apache.org/licenses/LICENSE-2.0
197 | 
198 |    Unless required by applicable law or agreed to in writing, software
199 |    distributed under the License is distributed on an "AS IS" BASIS,
200 |    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
201 |    See the License for the specific language governing permissions and
202 |    limitations under the License.
203 | 


--------------------------------------------------------------------------------
/src/interp.rs:
--------------------------------------------------------------------------------
  1 | //! The interpreter for `RustyScheme`.
  2 | //!
  3 | //! This is the part of `RustyScheme` that actually executes `RustyScheme`
  4 | //! bytecode.  It is a simple `match`-based interpreter.  Future optimizations
  5 | //! include using tail calls to implement the equivalent of computed gotos.
  6 | //!
  7 | //! The entry point is in `self::interpret_bytecode`.  Upon entering this
  8 | //! function (ex. from a Rust API call), the called function must be at the
  9 | //! bottom of the stack, followed by the arguments.
 10 | //!
 11 | //! Upon a Scheme->Scheme function call, the data stack layout is:
 12 | //!
 13 | //! |--------------------|
 14 | //! | arguments          |
 15 | //! |--------------------|
 16 | //! | caller function    |
 17 | //! |--------------------|
 18 | //!
 19 | //! and the control stack layout is:
 20 | //!
 21 | //! |--------------------|
 22 | //! | return address     |
 23 | //! |--------------------|
 24 | //! | old frame pointer  |
 25 | //! |--------------------|
 26 | //! | captured?          |
 27 | //! |--------------------|
 28 | //!
 29 | //! but these three objects are all held in a single Rust struct.
 30 | //!
 31 | //! `const STACK_OFFSET: usize` holds the difference between the old stack
 32 | //! pointer and the new frame pointer. `captured?` holds whether the Scheme
 33 | //! environment has been captured.
 34 | 
 35 | use std::ptr;
 36 | use value;
 37 | use alloc;
 38 | use arith;
 39 | 
 40 | use bytecode::{Bytecode, Opcode};
 41 | 
 42 | const STACK_OFFSET: usize = 1;
 43 | 
 44 | pub struct ActivationRecord {
 45 |     return_address: usize,
 46 |     frame_pointer: usize,
 47 |     captured: bool,
 48 | }
 49 | 
 50 | /// The Scheme state.  It has several parts:
 51 | ///
 52 | /// - the program counter (`program_counter`), which stores the current
 53 | ///   bytecode instruction position.
 54 | /// - the stack pointer `sp`, which stores the current stack position.
 55 | /// - the control stack `control_stack`, which stores control flow
 56 | ///   information.
 57 | /// - The environment pointer `env`, which (if non-NULL) points to the current
 58 | ///   environment.
 59 | /// - the bytecode `bytecode`, which stores the bytecode currently being
 60 | ///   executed.
 61 | pub struct State {
 62 |     program_counter: usize,
 63 |     sp: usize,
 64 |     control_stack: Vec<ActivationRecord>,
 65 |     bytecode: Vec<Bytecode>,
 66 |     pub heap: alloc::Heap,
 67 | }
 68 | 
 69 | /// Create a new Scheme interpreter
 70 | pub fn new() -> self::State {
 71 |     State {
 72 |         program_counter: 0,
 73 |         sp: 0,
 74 |         control_stack: vec![],
 75 |         heap: alloc::Heap::new(1 <<
 76 |                                if cfg!(debug_assertions) {
 77 |             4
 78 |         } else {
 79 |             16
 80 |         }),
 81 |         bytecode: vec![],
 82 |     }
 83 | }
 84 | 
 85 | 
 86 | /// This function interprets the Scheme bytecode.
 87 | pub fn interpret_bytecode(s: &mut State) -> Result<(), String> {
 88 |     let pc = &mut s.program_counter;
 89 |     let heap = &mut s.heap;
 90 |     heap.environment = ptr::null_mut();
 91 |     let sp = &mut s.sp;
 92 |     let mut fp = 0;
 93 |     loop {
 94 |         let Bytecode { opcode, src, src2, dst } = s.bytecode[*pc];
 95 |         let (src, src2, dst): (usize, usize, usize) = (src.into(), src2.into(), dst.into());
 96 |         // let len = heap.stack.len();
 97 |         match opcode {
 98 |             Opcode::Cons => {
 99 |                 heap.alloc_pair(src, src2);
100 |                 heap.stack[dst] = heap.stack.pop().unwrap();
101 |                 *pc += 1;
102 |             }
103 |             Opcode::Car => {
104 |                 heap.stack[dst] = try!(heap.stack[src]
105 |                                            .car()
106 |                                            .map_err(|()| {
107 |                                                "Attempt to take the \
108 |                                                 car of a non-pair"
109 |                                                    .to_owned()
110 |                                            }));
111 |                 *pc += 1;
112 |             }
113 |             Opcode::Cdr => {
114 |                 heap.stack[dst] = try!(heap.stack[src]
115 |                                            .cdr()
116 |                                            .map_err(|()| {
117 |                                                "Attempt to take the \
118 |                                                 cdr of a non-pair"
119 |                                                    .to_owned()
120 |                                            }));
121 |                 *pc += 1;
122 |             }
123 |             Opcode::SetCar => {
124 |                 try!(heap.stack[dst]
125 |                          .set_car(heap.stack[src].clone())
126 |                          .map_err(|()| "Attempt to set the car of a non-pair".to_owned()));
127 |                 *pc += 1;
128 |             }
129 |             Opcode::SetCdr => {
130 |                 try!(heap.stack[dst]
131 |                          .set_cdr(heap.stack[src].clone())
132 |                          .map_err(|()| "Attempt to set the cdr of a non-pair".to_owned()));
133 |                 *pc += 1;
134 |             }
135 |             Opcode::Set => {
136 |                 heap.stack[dst] = heap.stack[src].clone();
137 |                 *pc += 1;
138 |             }
139 |             Opcode::Add => {
140 |                 // The hot paths are fixnums and flonums.  They are inlined.
141 |                 // Most scripts probably do not heavily use complex numbers.
142 |                 // Bignums or rationals will always be slow.
143 |                 let (fst, snd) = (heap.stack[src].get(), heap.stack[src2].get());
144 |                 heap.stack.push(if fst & snd & 3 == 0 {
145 |                     value::Value::new(fst.wrapping_add(snd)) // TODO: bignumx
146 |                 } else {
147 |                     return Err("wrong type to add".to_owned());
148 |                 });
149 |                 *pc += 1;
150 |             }
151 | 
152 |             Opcode::Subtract => {
153 |                 let (fst, snd) = (heap.stack[src].clone(), heap.stack[src2].clone());
154 |                 // See above.
155 |                 heap.stack[dst] = try!(arith::subtract(heap, &fst, &snd));
156 |                 *pc += 1;
157 |             }
158 | 
159 |             Opcode::Multiply => {
160 |                 // See above.
161 |                 let (fst, snd) = (heap.stack[src].clone(), heap.stack[src2].clone());
162 |                 heap.stack[dst] = try!(arith::multiply(heap, &fst, &snd));
163 |                 *pc += 1;
164 |             }
165 | 
166 |             Opcode::Divide => {
167 |                 // See above.
168 |                 let (fst, snd) = (heap.stack[src].clone(), heap.stack[src2].clone());
169 |                 heap.stack[dst] = try!(arith::divide(heap, &fst, &snd));
170 |                 *pc += 1;
171 |             }
172 | 
173 |             Opcode::Power => {
174 |                 // See above.
175 |                 let (fst, snd) = (heap.stack[src].clone(), heap.stack[src2].clone());
176 |                 heap.stack[dst] = arith::exponential(fst, snd);
177 |                 *pc += 1;
178 |             }
179 | 
180 |             Opcode::Closure => {
181 |                 heap.alloc_closure(src as u8, src2 as u8, dst);
182 |                 let len = heap.stack.len();
183 |                 heap.environment = unsafe { heap.stack[len - 1].as_ptr() } as *mut value::Vector;
184 |                 *pc += 1;
185 |             }
186 | 
187 |             Opcode::MakeArray => {
188 |                 alloc::Heap::alloc_vector(heap, src, src2);
189 |                 *pc += 1;
190 |             }
191 | 
192 |             Opcode::SetArray => {
193 |                 let index = try!(heap.stack[src].as_fixnum());
194 |                 try!(heap.stack[dst].array_set(index, &heap.stack[src2]));
195 |                 *pc += 1;
196 |             }
197 | 
198 |             Opcode::GetArray => {
199 |                 let index = try!(heap.stack[src].as_fixnum());
200 |                 heap.stack[dst] = try!(heap.stack[src2]
201 |                                            .array_get(index)
202 |                                            .map(|ptr| unsafe { (*ptr).clone() }));
203 |                 *pc += 1;
204 |             }
205 | 
206 |             // Frame layout: activation record below rest of data
207 |             Opcode::Call => {
208 |                 let frame_pointer = *sp - src - 1;
209 |                 s.control_stack.push(ActivationRecord {
210 |                     return_address: *pc,
211 |                     frame_pointer: frame_pointer,
212 |                     captured: !heap.environment.is_null(),
213 |                 });
214 |                 *pc = 0;
215 |                 *sp = heap.stack.len();
216 |                 fp = frame_pointer;
217 |             }
218 | 
219 |             Opcode::LoadFalse => {
220 |                 heap.stack.push(value::Value::new(value::FALSE));
221 |             }
222 | 
223 |             Opcode::LoadTrue => {
224 |                 heap.stack.push(value::Value::new(value::TRUE));
225 |             }
226 | 
227 |             Opcode::LoadNil => heap.stack.push(value::Value::new(value::NIL)),
228 |             Opcode::TailCall => {
229 |                 let (first, rest) = heap.stack.split_at_mut(*sp - src - 1);
230 |                 *pc = 0;
231 |                 *sp = fp + src + 1;
232 |                 first[fp..*sp].clone_from_slice(rest);
233 |             }
234 | 
235 |             Opcode::Return => {
236 |                 if let Some(return_frame) = s.control_stack.pop() {
237 |                     *sp = fp;
238 |                     *pc = return_frame.return_address;
239 |                     fp = return_frame.frame_pointer
240 |                 } else {
241 |                     return Ok(());
242 |                 }
243 |             }
244 | 
245 |             Opcode::LoadEnvironment => {
246 |                 let to_be_pushed = if heap.environment.is_null() {
247 |                     heap.stack[src + fp].clone()
248 |                 } else {
249 |                     unsafe {
250 |                         (*value::Value::raw_array_get(heap.environment as *const _, src).unwrap())
251 |                             .clone()
252 |                     }
253 |                 };
254 |                 heap.stack.push(to_be_pushed.clone());
255 |                 *pc += 1;
256 |             }
257 | 
258 |             Opcode::LoadConstant => {
259 |                 let x = unsafe {
260 |                     (*value::Value::raw_array_get(heap.constants, src).unwrap()).clone()
261 |                 };
262 |                 heap.stack.push(x);
263 |                 *pc += 1;
264 |             }
265 | 
266 |             Opcode::LoadArgument => {
267 |                 let x = heap.stack[fp + src].clone();
268 |                 heap.stack.push(x);
269 |                 *pc += 1;
270 |             }
271 | 
272 |             Opcode::StoreArgument => {
273 |                 let x = heap.stack.pop().unwrap();
274 |                 heap.stack[fp + src] = x;
275 |                 *pc += 1;
276 |             }
277 | 
278 |             Opcode::StoreEnvironment => {
279 |                 let to_be_stored = heap.stack.pop().unwrap();
280 |                 if heap.environment.is_null() {
281 |                     heap.stack[src] = to_be_stored
282 |                 } else {
283 |                     unsafe {
284 |                         value::Value::raw_array_set(heap.environment, src, to_be_stored).unwrap()
285 |                     }
286 |                 }
287 |                 *pc += 1;
288 |             }
289 | 
290 |             Opcode::LoadGlobal => {
291 |                 *pc += 1;
292 |                 try!(heap.load_global())
293 |             }
294 | 
295 |             Opcode::StoreGlobal => {
296 |                 *pc += 1;
297 |                 try!(heap.store_global())
298 |             }
299 |             _ => unimplemented!(),
300 |         }
301 |     }
302 | }
303 | 
304 | 
305 | 
306 | 
307 | #[cfg(test)]
308 | mod tests {
309 |     use value::Value;
310 |     use std::cell::Cell;
311 |     use bytecode::{Opcode, Bytecode};
312 |     #[test]
313 |     fn can_cons() {
314 |         let mut bco = super::new();
315 |         bco.heap.stack.push(Value { contents: Cell::new(0) });
316 |         bco.heap.stack.push(Value { contents: Cell::new(0) });
317 |         assert!(bco.heap.stack.len() == 2);
318 |         bco.bytecode.push(Bytecode {
319 |             opcode: Opcode::Cons,
320 |             src: 0,
321 |             src2: 1,
322 |             dst: 1,
323 |         });
324 |         bco.bytecode.push(Bytecode {
325 |             opcode: Opcode::Return,
326 |             src: 0,
327 |             src2: 0,
328 |             dst: 0,
329 |         });
330 |         assert!(super::interpret_bytecode(&mut bco).is_ok());
331 |     }
332 | }
333 | 


--------------------------------------------------------------------------------
/src/api/mod.rs:
--------------------------------------------------------------------------------
  1 | //! The public Rust embedding API of `RustyScheme`.  Very unstable.
  2 | //!
  3 | //! This API is similar to Lua's embedding API, in that an explicit stack is
  4 | //! used.
  5 | //!
  6 | //! Example:
  7 | //!
  8 | //! ```rust
  9 | //! use rusty_scheme;
 10 | //! let mut interp = rusty_scheme::State::new();
 11 | //!
 12 | //! // Push onto the stack.  Always works, unless the interpreter
 13 | //! // hits the memory limit set by the embedder (not yet implemented).
 14 | //! assert!(interp.push(23).is_ok());
 15 | //! assert!(interp.push(175).is_ok());
 16 | //!
 17 | //! // Compute the sum of these numbers
 18 | //! //assert!(interp.sum(-1, -2).is_ok());
 19 | //! //assert!(interp.pop().unwrap() == 198);
 20 | //!
 21 | //! // Now something more interesting: executing Scheme source code.
 22 | //! //assert!(interp.eval("(+ 123 657)").is_ok());
 23 | //! //assert!(interp.call(0).is_ok());
 24 | //! //assert!(interp.pop().unwrap() == 123 + 657);
 25 | //!
 26 | //! // Now let's try an error:
 27 | //! //assert!(interp.eval("(+ 1 5").is_err());
 28 | //! ```
 29 | 
 30 | extern crate env_logger;
 31 | 
 32 | mod pool;
 33 | 
 34 | use interp;
 35 | use value;
 36 | use alloc;
 37 | use arith;
 38 | pub struct State {
 39 |     state: interp::State,
 40 |     fp: usize,
 41 | }
 42 | 
 43 | 
 44 | // Unsafe because the return value is not rooted
 45 | pub unsafe trait SchemeValue: Sized {
 46 |     fn to_value(&self, heap: &mut alloc::Heap) -> value::Value;
 47 |     fn of_value(val: &value::Value) -> Result<Self, String>;
 48 | }
 49 | 
 50 | unsafe impl SchemeValue for usize {
 51 |     fn to_value(&self, _: &mut alloc::Heap) -> value::Value {
 52 |         if self & 3 << (size_of!(usize) * 8 - 2) != 0 {
 53 |             panic!("bignums not yet supported")
 54 |         } else {
 55 |             value::Value::new(self << 2)
 56 |         }
 57 |     }
 58 |     fn of_value(val: &value::Value) -> Result<Self, String> {
 59 |         val.as_fixnum().map_err(|x| x.to_owned())
 60 |     }
 61 | }
 62 | 
 63 | unsafe impl SchemeValue for bool {
 64 |     fn to_value(&self, _: &mut alloc::Heap) -> value::Value {
 65 |         value::Value::new(if *self {
 66 |             value::TRUE
 67 |         } else {
 68 |             value::FALSE
 69 |         })
 70 |     }
 71 |     fn of_value(val: &value::Value) -> Result<Self, String> {
 72 |         match val.get() {
 73 |             value::TRUE => Ok(true),
 74 |             value::FALSE => Ok(false),
 75 |             x => Err(format!("Bad bool {:x}", x)),
 76 |         }
 77 |     }
 78 | }
 79 | 
 80 | impl Default for State {
 81 |     fn default() -> Self {
 82 |         Self::new()
 83 |     }
 84 | }
 85 | impl State {
 86 |     pub fn new() -> Self {
 87 |         State {
 88 |             state: interp::new(),
 89 |             fp: (-1isize) as usize,
 90 |         }
 91 |     }
 92 | 
 93 |     pub fn execute_bytecode(&mut self) -> Result<(), String> {
 94 |         interp::interpret_bytecode(&mut self.state)
 95 |     }
 96 | 
 97 |     pub fn push<T: SchemeValue>(&mut self, value: T) -> Result<(), ()> {
 98 |         let state = &mut self.state;
 99 |         let new_val = value.to_value(&mut state.heap);
100 |         Ok(state.heap.stack.push(new_val))
101 |     }
102 | 
103 |     /// Pops the top of the stack and converts it to a Rust value.
104 |     pub fn pop<T: SchemeValue>(&mut self) -> Result<T, String> {
105 |         let x = self.state.heap.stack.pop();
106 |         match x {
107 |             Some(v) => T::of_value(&v),
108 |             None => Err("Attempt to pop from empty stack".to_owned()),
109 |         }
110 |     }
111 | 
112 |     /// Pops and discards the top of the stack.
113 |     pub fn drop(&mut self) -> Result<(), String> {
114 |         match self.state.heap.stack.pop() {
115 |             Some(_) => Ok(()),
116 |             None => Err("Attempt to pop from empty stack".to_owned()),
117 |         }
118 |     }
119 | 
120 |     /// Pushes the cons of the top two values on the stack.
121 |     pub fn cons(&mut self) -> Result<(), String> {
122 |         let len = self.state.heap.stack.len();
123 |         debug_assert!(len > 1);
124 |         self.state.heap.alloc_pair(len - 2, len - 1);
125 |         Ok(())
126 |     }
127 | 
128 |     /// Creates a list whose elements are the top `arg - 1` elements of the
129 |     /// stack.  The top of the stack becomes the `cdr` of the last pair.
130 |     pub fn list_with_tail(&mut self, arg: usize) -> Result<(), String> {
131 |         let len = self.len();
132 |         if arg > len - 1 {
133 |             return Err("Attempt to make a list longer than the stack \
134 |                         is deep".to_owned())
135 |         }
136 |         //error!("Stack depth: {:?}, args: {:?}", self.len(), arg);
137 |         for _ in 0..(arg) {
138 |             let q = self.len();
139 |             try!(self.cons());
140 |             self.store(2, 0);
141 |             self.state.heap.stack.pop();
142 |             self.state.heap.stack.pop();
143 |             debug_assert_eq!(q, self.len() + 1)
144 |         }
145 |         debug_assert_eq!(len, self.len() + arg);
146 |         //error!("Stack depth: {:?}", self.len());
147 |         Ok(())
148 |     }
149 | 
150 |     pub fn list(&mut self, arg: usize) -> Result<(), String> {
151 |         self.push_nil();
152 |         self.list_with_tail(arg)
153 |     }
154 | 
155 |     pub fn car(&mut self) -> Result<value::Value, String> {
156 |         let len = self.state.heap.stack.len();
157 |         self.state.heap.stack[len - 1]
158 |             .car()
159 |             .map_err(|()| "Attempt to take the car of a non-pair".to_owned())
160 |     }
161 |     pub fn cdr(&mut self) -> Result<(), String> {
162 |         let len = self.state.heap.stack.len();
163 |         let new_val = try!(self.state.heap.stack[len - 1]
164 |                                .cdr()
165 |                                .map_err(|()| "Attempt to take the cdr of a non-pair".to_owned()));
166 |         Ok(self.state.heap.stack[len - 1] = new_val)
167 |     }
168 |     pub fn intern(&mut self, object: &str) -> Result<(), String> {
169 |         Ok(self.state.heap.intern(object))
170 |     }
171 | 
172 |     pub fn set(&mut self, src: usize, dst: usize) -> () {
173 |         let heap = &mut self.state.heap;
174 |         let fp = self.fp;
175 |         heap.stack[dst - fp] = heap.stack[src - fp].clone();
176 |     }
177 |     pub fn add(&mut self, src: usize, src2: usize) -> Result<(), ()> {
178 |         let fp = self.fp;
179 |         let heap = &mut self.state.heap;
180 |         // The hot paths are fixnums and flonums.  They are inlined.
181 |         // Most scripts probably do not heavily use complex numbers.
182 |         // Bignums or rationals will always be slow.
183 |         let (fst, snd) = (heap.stack[src - fp].get(), heap.stack[src2 - fp].get());
184 |         heap.stack.push(if fst & snd & 3 == 0 {
185 |             value::Value::new(fst.wrapping_add(snd)) // TODO: bignums
186 |         } else {
187 |             return Err(());
188 |         });
189 |         Ok(())
190 |     }
191 | 
192 |     pub fn subtract(&mut self, src: usize, src2: usize) -> Result<(), String> {
193 |         let fp = self.fp;
194 |         let heap = &mut self.state.heap;
195 |         let (fst, snd) = (heap.stack[src - fp].clone(), heap.stack[src2 - fp].clone());
196 |         // See above.
197 |         let to_be_pushed = try!(arith::subtract(heap, &fst, &snd));
198 |         Ok(heap.stack.push(to_be_pushed))
199 |     }
200 | 
201 |     pub fn multiply(&mut self, src: usize, src2: usize) -> Result<(), String> {
202 |         // See above.
203 |         let fp = self.fp;
204 |         let heap = &mut self.state.heap;
205 |         let (fst, snd) = (heap.stack[src - fp].clone(), heap.stack[src2 - fp].clone());
206 |         arith::multiply(heap, &fst, &snd).map(|_| ())
207 |     }
208 | 
209 |     pub fn divide(&mut self, src: usize, src2: usize, dst: usize) -> Result<(), String> {
210 |         // See above.
211 |         let fp = self.fp;
212 |         let heap = &mut self.state.heap;
213 |         let (fst, snd) = (heap.stack[src - fp].clone(), heap.stack[src2 - fp].clone());
214 |         heap.stack[dst - fp] = try!(arith::divide(heap, &fst, &snd));
215 |         Ok(())
216 |     }
217 | 
218 |     pub fn exponential(&mut self, src: usize, src2: usize, _dst: usize) -> Result<(), String> {
219 |         // See above.
220 |         let fp = self.fp;
221 |         let heap = &mut self.state.heap;
222 |         let (fst, snd) = (heap.stack[src - fp].clone(), heap.stack[src2 - fp].clone());
223 |         heap.stack[_dst - fp] = arith::exponential(fst, snd);
224 |     }
225 | 
226 |     pub fn vector(&mut self, src: usize, src2: usize) -> Result<(), String> {
227 |         debug_assert!(src2 >= src);
228 |         Ok(alloc::Heap::alloc_vector(&mut self.state.heap, src, src2))
229 |     }
230 | 
231 |     pub fn array_set(&mut self, index: usize, src: usize, dst: usize) -> Result<(), String> {
232 |         let fp = self.fp;
233 |         let heap = &mut self.state.heap;
234 |         heap.stack[dst - fp].array_set(index, &heap.stack[src])
235 |     }
236 | 
237 |     pub fn array_get(&mut self, index: usize, src: usize, dst: usize) -> Result<(), String> {
238 |         let fp = self.fp;
239 |         let heap = &mut self.state.heap;
240 |         heap.stack[dst + fp] = try!(heap.stack[src + fp]
241 |                                         .array_get(index)
242 |                                         .map(|ptr| unsafe { (*ptr).clone() }));
243 |         Ok(())
244 |     }
245 | 
246 |     pub fn push_false(&mut self) {
247 |         self.state.heap.stack.push(value::Value::new(value::FALSE));
248 |     }
249 | 
250 |     pub fn push_true(&mut self) {
251 |         let heap = &mut self.state.heap;
252 |         heap.stack.push(value::Value::new(value::TRUE));
253 |     }
254 | 
255 |     pub fn push_nil(&mut self) {
256 |         let heap = &mut self.state.heap;
257 |         heap.stack.push(value::Value::new(value::NIL))
258 |     }
259 | 
260 |     pub fn load_global(&mut self) -> Result<(), String> {
261 |         self.state.heap.load_global()
262 |     }
263 | 
264 |     pub fn load(&mut self, src: usize) {
265 |         let stack = &mut self.state.heap.stack;
266 |         let val = stack[stack.len() - src - 1].clone();
267 |         stack.push(val);
268 |     }
269 | 
270 |     pub fn len(&self) -> usize {
271 |         self.state.heap.stack.len()
272 |     }
273 | 
274 |     pub fn is_empty(&self) -> bool {
275 |         self.len() == 0
276 |     }
277 | 
278 |     pub fn store(&mut self, src: usize, dst: usize) {
279 |         let stack = &mut self.state.heap.stack;
280 |         let len = stack.len();
281 |         stack[len - dst - 1] = stack[len - src - 1].clone();
282 |     }
283 | 
284 |     pub fn store_global(&mut self) -> Result<(), String> {
285 |         self.state.heap.store_global()
286 |     }
287 |     pub fn gc(&mut self) {
288 |         alloc::collect(&mut self.state.heap)
289 |     }
290 | }
291 | 
292 | #[cfg(test)]
293 | mod tests {
294 |     extern crate env_logger;
295 |     use super::*;
296 |     #[test]
297 |     fn push_and_pop_fixnum() {
298 |         let mut interp = State::new();
299 |         let _ = interp.push(127);
300 |         let x: Result<usize, _> = interp.pop();
301 |         assert_eq!(x.unwrap(), 127)
302 |     }
303 | 
304 |     #[test]
305 |     fn intern_many_strings() {
306 |         let _ = env_logger::init();
307 |         let mut interp = State::new();
308 |         let x = "Test string!".to_owned();
309 |         for _ in &[0..1000] {
310 |             interp.push(x.clone()).unwrap();
311 |         }
312 |         for _ in &[0..1000] {
313 |             assert_eq!(interp.pop(), Ok(x.clone()))
314 |         }
315 |     }
316 |     #[test]
317 |     fn intern_many_symbols() {
318 |         let _ = env_logger::init();
319 |         let mut interp = State::new();
320 |         interp.push_false();
321 |         interp.gc();
322 |         for i in 0..100 {
323 |             assert_eq!(interp.state.heap.stack.len(), 1);
324 |             assert_eq!(interp.state.heap.symbol_table.contents.len(), i);
325 |             let _ = interp.intern(&format!("Falcon {}", i));
326 |             assert_eq!(interp.state.heap.stack.len(), 2);
327 |             interp.load(1);// fresh symbol
328 |             assert_eq!(interp.state.heap.stack.len(), 3);
329 |             interp.load(1);// old symbol
330 |                 assert_eq!(interp.state.heap.stack.len(), 4);
331 |             interp.store_global().unwrap(); // stores old symbol into fresh symbol
332 |             assert_eq!(interp.state.heap.stack.len(), 2);
333 |             interp.store(0, 1);
334 |             assert_eq!(interp.state.heap.stack.len(), 2);
335 |             let x: Result<usize, _> = interp.pop();
336 |             assert!(x.is_err());
337 |             assert_eq!(interp.state.heap.stack.len(), 1);
338 |         }
339 |         assert_eq!(interp.state.heap.symbol_table.contents.len(), 100);
340 |         let x: Result<usize, _> = interp.pop();
341 |         assert!(x.is_err());
342 |         interp.gc();
343 |         assert_eq!(interp.state.heap.symbol_table.contents.len(), 0)
344 |     }
345 | }
346 | 


--------------------------------------------------------------------------------
/src/value.rs:
--------------------------------------------------------------------------------
  1 | //! The representation of Scheme values in `RustyScheme`.
  2 | //!
  3 | //! Inspired by the representation of Femtolisp.
  4 | //!
  5 | //! ### Representation
  6 | //!
  7 | //! | Type      | Representation |
  8 | //! |-----------|----------------|
  9 | //! |Fixnum     | As an immediate pointer, with tag 0 or 4.|
 10 | //! |Flonums    | As a pointer to a (boxed) floating-point number, with tag 1.|
 11 | //! |Pairs| As a pointer to a 2-tuple, with pointer tag 3. |
 12 | //! |Arrays| As an untagged, aligned pointer to a Rust slice. |
 13 | //! |Records| As a pointer to a Rust slice, with a special header for the GC that indicates how it should be marked.|
 14 | //! |Resources  | As a pointer into a 3-tuple, consisting of a GC header, a pointer to a `struct` that contains an object ID and custom equality, hashing, and other functions, and a pointer into memory not managed by the GC. |
 15 | 
 16 | use std::cell::Cell;
 17 | use symbol;
 18 | 
 19 | /// A Scheme value.
 20 | ///
 21 | /// Scheme values are garbage collected, so must never appear outside
 22 | /// the heap, stack, or handles.  The GC will invalidate any other `Value`,
 23 | /// creating a dangling pointer.
 24 | #[repr(packed)]
 25 | #[derive(Clone, Debug, PartialEq, Eq)]
 26 | pub struct Value {
 27 |     pub contents: Cell<usize>,
 28 | }
 29 | 
 30 | /// The basic structure of an arbitrary Scheme heap object.
 31 | #[repr(packed)]
 32 | pub struct SchemeObject<T: ?Sized> {
 33 |     header: usize,
 34 |     body: T,
 35 | }
 36 | 
 37 | /// The basic finalized Scheme object
 38 | #[repr(packed)]
 39 | pub struct FinalizedHeader {
 40 |     header: usize,
 41 |     next_object: *mut FinalizedHeader,
 42 | }
 43 | 
 44 | /// A Scheme "vector-like thing".
 45 | ///
 46 | /// Vector-like things are Scheme values with tag `Tags::Vector`.
 47 | /// They all consist of a header followed by a slice of Scheme values.
 48 | /// The number of Scheme words is always computable by the `len` method.
 49 | ///
 50 | /// Vector-like things have their own tags, in the 3 most significant bits
 51 | /// of the header word.  They have the following meanings:
 52 | ///
 53 | /// | Tag |Meaning|
 54 | /// |-----|-------|
 55 | /// |0b000|Vector (chosen to simplify bounds checks)|
 56 | /// |0b001|Record.  The first word points to a record descriptor
 57 | /// used to identify the record type.|
 58 | /// |Others|Reserved.  These may be later used by the run-time system.
 59 | ///
 60 | /// This struct _**cannot**_ be moved, because it is followed by Scheme
 61 | /// objects that are not a part of the object.  As such, it has no public
 62 | /// constructors, and can only be instantiated by reference.
 63 | #[repr(C)]
 64 | #[derive(Debug)]
 65 | pub struct Vector {
 66 |     /// Header.  Always has `0b000` as the 3 MSBs.
 67 |     header: usize,
 68 | }
 69 | 
 70 | /// A descriptor for a `Record`.
 71 | pub struct RecordDescriptor {
 72 |     /// Always a multiple of 8, but never zero.
 73 |     id: usize,
 74 | }
 75 | 
 76 | /// A Scheme record type.  This has the same memory layout as `Vector`,
 77 | /// but with a different header.
 78 | #[repr(C)]
 79 | #[derive(Debug)]
 80 | pub struct Record {
 81 |     /// Header.  Always starts with a nonzero 3 most significant bits.
 82 |     header: usize,
 83 | 
 84 |     /// Scheme values.
 85 |     data: [Value],
 86 | }
 87 | 
 88 | /// A (mutable) Scheme pair.  Subject to garbage collection.
 89 | #[repr(C)]
 90 | #[derive(Debug)]
 91 | pub struct Pair {
 92 |     /// Header.  Always `PAIR_HEADER` (checked by a debug assertion in the GC).
 93 |     pub header: usize,
 94 | 
 95 |     /// The `car` of the pair.
 96 |     pub car: Value,
 97 | 
 98 |     /// The `cdr` of the pair.
 99 |     pub cdr: Value,
100 | }
101 | 
102 | /// A Scheme closure.  Subject to garbage collection.
103 | #[repr(C)]
104 | #[derive(Debug)]
105 | pub struct Closure {
106 |     header: usize,
107 |     pub bytecode: Value, // a BCO
108 |     pub environment: [Value],
109 | }
110 | 
111 | 
112 | /// A Scheme bytecode instruction.
113 | #[repr(C)]
114 | #[derive(Copy, Clone, Debug)]
115 | pub struct Instruction {
116 |     pub opcode: u8,
117 |     pub src: u8,
118 |     pub src2: u8,
119 |     pub dst: u8,
120 | }
121 | 
122 | /// The Scheme immediate `#f`
123 | pub const FALSE: usize = 0x3;
124 | 
125 | /// The Scheme immediate `#t`
126 | pub const TRUE: usize = 0xB;
127 | 
128 | /// The Scheme empty list `()`
129 | pub const NIL: usize = 0x13;
130 | 
131 | /// The Scheme EOF object
132 | pub const EOF: usize = 0x1B;
133 | 
134 | /// The Scheme object representing an unspecified value
135 | pub const UNSPECIFIED: usize = 0x23;
136 | 
137 | pub struct SymbolValue {
138 |     backing: *mut Value,
139 | }
140 | 
141 | pub enum Kind {
142 |     Pair(*mut Pair),
143 |     Vector(*mut Vector),
144 |     Fixnum(usize),
145 |     Symbol(*mut symbol::Symbol),
146 | }
147 | 
148 | /// An object containing compiled Scheme bytecode.  Subject to garbage collection.
149 | #[repr(C)]
150 | #[derive(Debug)]
151 | pub struct BCO {
152 |     /// Header.  Indicates that this is a BCO.
153 |     header: usize,
154 | 
155 |     /// Actual bytecode
156 |     pub contents: [Instruction],
157 | }
158 | 
159 | impl Value {
160 |     #[inline(never)]
161 |     pub fn slow_add(_first: &Self, _second: &Self) -> Result<Self, SchemeError> {
162 |         unimplemented!()
163 |     }
164 | 
165 |     #[inline(always)]
166 |     pub fn subtract(_first: &Self, _second: &Self) -> Self {
167 |         unimplemented!()
168 |     }
169 | 
170 |     /// Returns the pointer stored in this object.  The object must not be
171 |     /// an immediate.
172 |     pub unsafe fn as_ptr(&self) -> *mut Value {
173 |         (self.get() & !0b111) as *mut Value
174 |     }
175 | 
176 |     /// The heap size of `self`, not including `self`.  Returns `None` for
177 |     /// immediate objects.
178 |     pub fn size(&self) -> Option<usize> {
179 |         if self.tag() == Tags::Symbol {
180 |             Some(0)
181 |         } else if self.immediatep() {
182 |             None
183 |         } else {
184 |             Some(unsafe { *((self.contents.get() & !0b111) as *const usize) & !HEADER_TAG })
185 |         }
186 |     }
187 | 
188 |     /// Set the `car` of a Scheme pair.  Returns `Err(())` if the object
189 |     /// is not a pair.
190 |     pub fn set_car(&self, other: Value) -> Result<(), ()> {
191 |         match self.kind() {
192 |             Kind::Pair(pair) => unsafe { Ok((*pair).car.set(other)) },
193 |             _ => Err(()),
194 |         }
195 |     }
196 | 
197 |     /// Set the `cdr` of a Scheme pair.  Returns `Err(())` if the object
198 |     /// is not a pair.
199 |     pub fn set_cdr(&self, other: Value) -> Result<(), ()> {
200 |         match self.kind() {
201 |             Kind::Pair(pair) => unsafe { Ok((*pair).cdr.set(other)) },
202 |             _ => Err(()),
203 |         }
204 |     }
205 | 
206 |     /// Get the `car` of a Scheme pair.  Returns `Err(())` if the object
207 |     /// is not a pair.
208 |     pub fn car(&self) -> Result<Self, ()> {
209 |         match self.kind() {
210 |             Kind::Pair(pair) => unsafe { Ok((*pair).car.clone()) },
211 |             _ => Err(()),
212 |         }
213 |     }
214 | 
215 |     pub fn cdr(&self) -> Result<Self, ()> {
216 |         match self.kind() {
217 |             Kind::Pair(pair) => unsafe { Ok((*pair).cdr.clone()) },
218 |             _ => Err(()),
219 |         }
220 |     }
221 |     pub fn new(contents: usize) -> Self {
222 |         Value { contents: Cell::new(contents) }
223 |     }
224 |     pub fn set(&self, other: Self) -> () {
225 |         self.contents.set(other.contents.get())
226 |     }
227 |     pub fn get(&self) -> usize {
228 |         self.contents.get()
229 |     }
230 |     pub fn array_set(&self, index: usize, other: &Value) -> Result<(), String> {
231 |         match self.kind() {
232 |             Kind::Vector(vec) => unsafe { Self::raw_array_set(vec, index, other.clone()) },
233 |             _ => Err("can't index a non-vector".to_owned()),
234 |         }
235 |     }
236 |     pub unsafe fn raw_array_set(vec: *mut Vector,
237 |                                 index: usize,
238 |                                 other: Value)
239 |                                 -> Result<(), String> {
240 |         if (*vec).header >= index {
241 |             Err((if (*vec).header & HEADER_TAG == 0 {
242 |                     "index out of bounds"
243 |                 } else {
244 |                     "can't index a non-record"
245 |                 })
246 |                 .to_owned())
247 |         } else {
248 |             (*((vec as usize + index) as *const Value)).set(other);
249 |             Ok(())
250 |         }
251 |     }
252 |     pub fn array_get(&self, index: usize) -> Result<*const Self, String> {
253 |         match self.kind() {
254 |             Kind::Vector(vec) => unsafe { Self::raw_array_get(vec, index) },
255 |             _ => Err("can't index a non-vector".to_owned()),
256 |         }
257 |     }
258 | 
259 |     pub unsafe fn raw_array_get(vec: *const Vector, index: usize) -> Result<*const Self, String> {
260 |         let index = index + 2;
261 |         if (*vec).header >= index {
262 |             Err((if (*vec).header & HEADER_TAG == 0 {
263 |                     "index out of bounds"
264 |                 } else {
265 |                     "can't index a non-record"
266 |                 })
267 |                 .to_owned())
268 |         } else {
269 |             Ok((vec as usize + index) as *const Value)
270 |         }
271 |     }
272 | 
273 |     pub fn kind(&self) -> Kind {
274 |         match self.tag() {
275 |             Tags::Pair => Kind::Pair(unsafe { self.as_ptr() } as *mut Pair),
276 |             Tags::Vector => Kind::Vector(unsafe { self.as_ptr() } as *mut Vector),
277 |             Tags::Num | Tags::Num2 => Kind::Fixnum(self.contents.get() >> 2),
278 |             Tags::Symbol => Kind::Symbol(unsafe { self.as_ptr() } as *mut symbol::Symbol),
279 |             _ => unimplemented!(),
280 |         }
281 |     }
282 | 
283 |     pub fn as_fixnum(&self) -> Result<usize, &'static str> {
284 |         match self.kind() {
285 |             Kind::Fixnum(val) => Ok(val),
286 |             _ => Err("not a fixnum"),
287 |         }
288 |     }
289 | }
290 | 
291 | #[repr(C)]
292 | pub struct Function {
293 |     header: usize,
294 |     bytecode: Value, // points to a byte code object
295 |     constants: Value, // points to a a vector of constants
296 | }
297 | 
298 | pub struct SchemeError(String);
299 | pub struct Bignum;
300 | impl Bignum {
301 |     pub fn new_from_fixnums(_x: usize, _y: usize) -> ! {
302 |         unimplemented!()
303 |     }
304 | }
305 | 
306 | pub unsafe fn float_val(val: &Value) -> f64 {
307 |     *((val.get() & 0b111) as *const f64)
308 | }
309 | 
310 | pub struct HashTable;
311 | pub struct IOPort;
312 | pub struct RustData;
313 | 
314 | // Same set used by Femtolisp
315 | /// The tag of `fixnum`s
316 | pub const NUM_TAG: usize = 0b000;
317 | 
318 | /// The tag of Rust-implemented functions.
319 | pub const RUST_FUNC_TAG: usize = 0b001;
320 | 
321 | /// The tag of Scheme-implemented functions.
322 | pub const FUNCTION_TAG: usize = 0b010;
323 | 
324 | /// The tag of Scheme vectors, records, and closures.
325 | pub const VECTOR_TAG: usize = 0b011;
326 | 
327 | /// The tag of non-`fixnum` immediates, such as the empty list,
328 | /// end-of-file object, the undefined value, and characters.
329 | pub const NUM_TAG_2: usize = 0b100;
330 | 
331 | /// The tag of `RustData` – Rust values stored on the Scheme heap.
332 | pub const RUST_DATA_TAG: usize = 0b101;
333 | 
334 | /// The tag of Symbols.
335 | pub const SYMBOL_TAG: usize = 0b110;
336 | 
337 | /// The tag of Pairs
338 | pub const PAIR_TAG: usize = 0b111;
339 | 
340 | #[cfg(target_pointer_width = "16")]
341 | pub const SIZEOF_PTR: usize = 2;
342 | 
343 | #[cfg(target_pointer_width = "32")]
344 | pub const SIZEOF_PTR: usize = 4;
345 | 
346 | #[cfg(target_pointer_width = "64")]
347 | pub const SIZEOF_PTR: usize = 8;
348 | 
349 | #[cfg(target_pointer_width = "128")]
350 | pub const SIZEOF_PTR: usize = 16;
351 | 
352 | /// The amount of memory occupied by a pair.
353 | pub const SIZEOF_PAIR: usize = (3 * self::SIZEOF_PTR + 0b111) >> 3;
354 | 
355 | /// Bitmask that includes the tag words of an object header.
356 | pub const HEADER_TAG: usize = 0b111 << (self::SIZEOF_PTR * 8 - 3);
357 | 
358 | /// The header of a pair.
359 | pub const PAIR_HEADER: usize = HeaderTag::Pair as usize + SIZEOF_PAIR;
360 | 
361 | #[cfg_attr(feature = "clippy", allow(enum_clike_unportable_variant))]
362 | #[repr(usize)]
363 | pub enum HeaderTag {
364 |     /// The header tag of a pair.
365 |     Pair = 0b11 << (self::SIZEOF_PTR * 8 - 2),
366 | 
367 |     /// The header tag of a function.
368 |     Bytecode = 0b101 << (self::SIZEOF_PTR * 8 - 3),
369 | 
370 |     /// The header of a `RustData`.
371 |     RustData = 0b100 << (self::SIZEOF_PTR * 8 - 3),
372 | 
373 |     /// The header of a closure
374 |     Closure = 0b011 << (self::SIZEOF_PTR * 8 - 3),
375 | 
376 |     /// The header of a finalized RustData
377 |     Finalized = 0b010 << (self::SIZEOF_PTR * 8 - 3),
378 | 
379 |     /// The header of a Scheme record
380 |     Record = 0b001 << (self::SIZEOF_PTR * 8 - 3),
381 | 
382 |     /// The header of a vector.
383 |     Vector = 0,
384 | }
385 | 
386 | #[derive(PartialEq, Eq, Debug, Copy, Clone)]
387 | pub enum Tags {
388 |     Num,
389 |     RustFunc,
390 |     Function,
391 |     Vector,
392 |     Num2,
393 |     RustData,
394 |     Symbol,
395 |     Pair,
396 | }
397 | 
398 | 
399 | impl Value {
400 |     pub fn raw_tag(&self) -> usize {
401 |         self.get() & 0b111
402 |     }
403 | 
404 |     pub fn tag(&self) -> Tags {
405 |         use self::Tags::*;
406 |         match self.raw_tag() {
407 |             NUM_TAG => Num,
408 |             RUST_FUNC_TAG => RustFunc,
409 |             FUNCTION_TAG => Function,
410 |             VECTOR_TAG => Vector,
411 |             NUM_TAG_2 => Num2,
412 |             RUST_DATA_TAG => RustData,
413 |             SYMBOL_TAG => Symbol,
414 |             PAIR_TAG => Pair,
415 |             _ => unreachable!(),
416 |         }
417 |     }
418 |     // #[inline(always)]
419 |     pub fn leafp(&self) -> bool {
420 |         self.raw_tag() & 0b10 == 0
421 |     }
422 |     // #[inline(always)]
423 |     pub fn both_fixnums(&self, other: &Self) -> bool {
424 |         (self.get() | other.get()) & 0b11 == 0
425 |     }
426 |     // #[inline(always)]
427 |     pub fn self_evaluating(&self) -> bool {
428 |         self.raw_tag() < 6
429 |     }
430 |     // #[inline(always)]
431 |     pub fn fixnump(&self) -> bool {
432 |         self.raw_tag() & 0b11 == 0
433 |     }
434 |     // #[inline(always)]
435 |     pub fn pairp(&self) -> bool {
436 |         self.tag() == Tags::Pair
437 |     }
438 |     #[inline(always)]
439 |     pub fn flonump(&self) -> bool {
440 |         unimplemented!()
441 |     }
442 | 
443 |     // n#[inline(always)]
444 |     pub fn immediatep(&self) -> bool {
445 |         let val = self.get();
446 |         val & 0b11 == 0 || val <= 0xFF // special immediates
447 |     }
448 | }
449 | 
450 | macro_rules! size_of {
451 |     ($ty:ty) => {
452 |         ::std::mem::size_of::<$ty>()
453 |     }
454 | }
455 | 


--------------------------------------------------------------------------------
/lib/tree-walk.scm:
--------------------------------------------------------------------------------
  1 | ;;;; -*- scheme -*-
  2 | ;;;; Copyright 2016 Demi Marie Obenour.
  3 | ;;;;
  4 | ;;;; Licensed under the Apache License, Version 2.0 or the MIT license at your
  5 | ;;;; discretion.  This file may not be copied, modified, or distributed except
  6 | ;;;; in accordence with those terms.
  7 | 
  8 | ;;; ### Tree walking and lowering – RustyScheme
  9 | ;;;
 10 | ;;; This library walks a Scheme program recursively,
 11 | ;;; compiling each form it reaches.  It makes several assumptions:
 12 | ;;;
 13 | ;;; - All `let` forms have been desugared.
 14 | ;;; - All special forms are valid.  This is checked, but the error messages
 15 | ;;;   are very poor.  It is much better for the checking to be done
 16 | ;;;   by the macro expander.
 17 | 
 18 | (import
 19 |  (only (rnrs base) car cdr pair? symbol? error define lambda)
 20 |  (rnrs base)
 21 |  (rnrs io simple)
 22 |  (only (rnrs eval) eval)
 23 |  (only (srfi :1) proper-list? circular-list? fold)
 24 |  (only (srfi :43) vector-copy)
 25 |  (only (srfi :69) hash-table-set! hash-table-ref)
 26 |  (only (guile) interaction-environment parameterize)
 27 |  (only (ice-9 pretty-print) pretty-print))
 28 | 
 29 | (define (translate-define form)
 30 |   "Convert (define (a b) q) to (set! a (lambda (b) q))"
 31 |   (assert (pair? form))
 32 |   #;(pretty-print form)
 33 |   (assert (or (eqv? (car form) 'define) (eqv? (car form) 'define-macro)))
 34 |   (if (pair? (cdr form))
 35 |       (let ((head (cadr form)))
 36 |         (cons 'set!
 37 |               (if (pair? head)
 38 |                   `(,(car head) (lambda ,(cdr head) ,@(cddr form)))
 39 |                   (cdr form))))
 40 |       (error 'syntax "Bad define form" form)))
 41 | 
 42 | (define (check-let-bindings bindings bad-binding-msg
 43 |                             bad-all-bindings-msg)
 44 |   "Check that `let` bindings are valid"
 45 |   (or (proper-list? bindings)
 46 |       (error 'syntax (vector bad-all-bindings-msg bindings)))
 47 |   (for-each
 48 |    (lambda (binding)
 49 |      (or (and (pair? binding)
 50 |               (symbol? (car binding))
 51 |               (let ((rest (cdr binding)))
 52 |                 (and (pair? rest)
 53 |                      (symbol? (car rest))
 54 |                      (null? (cdr rest)))))
 55 |          (error 'syntax bad-binding-msg binding bindings)))
 56 |    bindings))
 57 | 
 58 | (define (source-location form) #f)
 59 | 
 60 | ;;; Contains code from system.lsp
 61 | (define (compile-letrec form env bco is-tail?)
 62 |   (compile-form
 63 |    (let ((binds (car form))
 64 |          (body (cdr form)))
 65 |      `((lambda ,(map car binds)
 66 |          ,@(map (lambda (b) `(set! ,@b)) binds)
 67 |          ,@body)
 68 |        ,@(map (lambda (x) (void)) binds)))
 69 |    env bco is-tail?))
 70 | 
 71 | ;;; Contains code from system.lsp, which is not by me.
 72 | (define (compile-let form env bco is-tail?)
 73 |   (compile-form
 74 |    (let ((binds (car form))
 75 |          (body (cdr form)))
 76 |      (let ((lname #f))
 77 |        (if (symbol? binds)
 78 |            (begin (set! lname binds)
 79 |                   (set! binds (car body))
 80 |                   (set! body (cdr body))))
 81 |        (let ((thelambda
 82 |               `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
 83 |                              binds)
 84 |                  ,@body))
 85 |              (theargs
 86 |               (map (lambda (c) (if (pair? c) (cadr c) (void))) binds)))
 87 |          (cons (if lname
 88 |                    `(letrec ((,lname ,thelambda)) ,lname)
 89 |                    thelambda)
 90 |                theargs)))) env bco is-tail?))
 91 | 
 92 | ;; Immediately applied simple lambdas are treated specially.
 93 | ;; Specifically, they are treated as `let` forms.  This allows
 94 | ;; `let` to desugar to `lambda` with no loss of performance.
 95 | (define (compile-initial-pair pair head rest-of-form env bco is-tail)
 96 |   (if (and (eq? (car head) 'lambda)
 97 |            (proper-list? head)
 98 |            (> (length head) 2))
 99 |       ;; Immediately applied simple lambda
100 |       (let ((arglist (cadr head)))
101 |         (if (not (= (length arglist) (length rest-of-form)))
102 |             (error 'syntax "Wrong number of arguments \
103 | to immediately-invoked lambda" pair))
104 |         (let ((depth (stack-depth bco)))
105 |           (for-each (lambda (x) (compile-form x env bco #f)) rest-of-form)
106 |           (for-each (lambda (x)
107 |                       (bind-variable x env (+ 1 depth))
108 |                       (set! depth (+ 1 depth)))
109 |                     arglist)
110 |           (compile-sequence (cddr head) env bco is-tail)
111 |           (for-each (lambda (sym) (unbind-argument sym env)) arglist)))
112 |       (begin
113 |         (compile-pair head env bco #f)
114 |         (compile-function-call (stack-depth bco)
115 |                                rest-of-form env bco is-tail)))
116 |   (values))
117 | 
118 | ;; Compile a pair (the only hard case)
119 | (define (compile-pair pair env bco is-tail?)
120 |   (assert (pair? pair))
121 |   (let ((rest-of-form (cdr pair))
122 |         (head (car pair)))
123 |     (or (proper-list? rest-of-form)
124 |         (error 'syntax "Pair to be compiled must be proper list" pair))
125 |     (cond
126 |      ((pair? head)
127 |       (compile-initial-pair pair head rest-of-form env bco is-tail?))
128 |      ((symbol? head)
129 |       (case head
130 |         ((quote)
131 |          (if (and (pair? rest-of-form) (null? (cdr rest-of-form)))
132 |              (emit-constant bco (car rest-of-form))
133 |              (error 'syntax "Bad quote form" pair)))
134 |         ((let) (compile-let rest-of-form env bco is-tail?))
135 |         ((letrec) (compile-letrec rest-of-form env bco is-tail?))
136 |         ((begin) (compile-sequence rest-of-form env bco is-tail?))
137 |         ((if) (compile-if rest-of-form env bco is-tail?))
138 |         ((lambda) (compile-lambda rest-of-form env bco))
139 |         ((define) (compile-define pair env bco))
140 |         ((set!) (compile-set! rest-of-form env bco))
141 |         (else
142 |          (let ((expander
143 |                 (hash-table-ref (env.macros env) head
144 |                                 (lambda () #f))))
145 |            (assert (or expander (not (eq? head 'cond))))
146 |            (if expander
147 |                (begin
148 |                  #;(pretty-print rest-of-form)
149 |                  (compile-form (apply expander rest-of-form) env bco is-tail?))
150 |                (begin
151 |                  (compile-function-call
152 |                   (lookup-environment env head bco) rest-of-form env bco
153 |                   is-tail?)))))))
154 |      (else
155 |       (error 'syntax "Invalid procedure in function call" pair))))
156 |   )
157 | 
158 | ;; Compile a lambda
159 | (define (compile-lambda form env bco)
160 |   "Compile a lambda form to bytecode."
161 |   ;;(assert (env? env))
162 |   (let ((lambda-list (car form)))
163 |     (if (circular-list? lambda-list)
164 |         (error 'syntax "Circular list in lambda detected" lambda-list))
165 |     (let-values
166 |         (((variadic? fixed-args symbols)
167 |           (let cont ((pair lambda-list) (len 0)
168 |                      (symbols '()))
169 |             (cond
170 |              ((pair? pair)
171 |               (let ((symbol (car pair)))
172 |                 (cont (cdr pair) (+ 1 len) (cons symbol symbols))))
173 |              ((null? pair) (values #f len symbols))
174 |              ((symbol? pair)
175 |               (values #t len symbols))
176 |              (else
177 |               (error 'syntax "Invalid lambda – non-symbol rest" pair))))))
178 |       (emit-lambda-definition bco variadic? fixed-args
179 |                               (lambda ()
180 |                                 (bind-arguments symbols env)
181 |                                 (compile-sequence (cdr form) env bco #t)
182 |                                 (map (lambda (x) (unbind-argument x env))
183 |                                      symbols)))))
184 |   (values))
185 | 
186 | (define (compile-scope form env bco is-tail)
187 |   "Compile a sequence to bytecode.  Internal defines are properly handled."
188 |   (if (not (proper-list? form))
189 |       (error 'syntax "Only proper lists allowed as sequences" form))
190 |   (if (null? form)
191 |       (error 'syntax "Sequences must be of positive length" form))
192 |   (let ((set!-expressions '())
193 |         (bound-vars '()))
194 |     (let cont ((form form)
195 |                (maybe-tail #t))
196 |       (assert (pair? form))
197 |       (let* ((head (car form))
198 |              (rest (cdr form))
199 |              (end-of-tree (and maybe-tail (null? rest))))
200 |         (define (not-still-in-defines)
201 |           (let ((set!-expressions (reverse! set!-expressions))
202 |                 (bound-vars (reverse! bound-vars)))
203 |             (for-each (lambda (x)
204 |                         (emit bco 'load-t)
205 |                         (bind-variable env x (stack-depth bco))) bound-vars)
206 |             (for-each (lambda (x) (compile-form x env bco #f)) set!-expressions)
207 |             (compile-form head env bco is-tail)
208 |             (if (pair? rest)
209 |                 (compile-sequence rest env bco (and is-tail end-of-tree)))
210 |             (values)))
211 |         (if (pair? head)
212 |             (case (car head)
213 |               ((begin)
214 |                (if (cont (cdr head) end-of-tree)
215 |                    ;; Yes – still scanning defines
216 |                    (cont rest end-of-tree)
217 |                    ;; No – switch to compiling a sequence
218 |                    (begin
219 |                      (compile-sequence rest env bco (and is-tail end-of-tree))
220 |                      #f)))
221 |               ((define)
222 |                (if end-of-tree
223 |                    ;; `define` form in tail position is an error,
224 |                    ;; since the expression would not evaluate to any value
225 |                    (error 'syntax "Sequence without expressions")
226 |                    (let ((translated (translate-define (cdr head))))
227 |                      (set! set!-expressions (cons translated set!-expressions))
228 |                      (set! bound-vars (cons bound-vars (cadr translated)))
229 |                      (cont rest end-of-tree))))
230 |               (else (not-still-in-defines)))
231 |             (not-still-in-defines))))))
232 | 
233 | (define (compile-if pair env bco is-tail)
234 |   "Compile a Scheme `if` expression to Scheme bytecode"
235 |   (let ((length-of-pair (length pair)))
236 |     (or (and (>= length-of-pair 2) (<= length-of-pair 3))
237 |         (error 'syntax "\"if\" takes at least 2 arguments, \
238 | but not more than 3")))
239 |   (emit-jump bco
240 |              (lambda ()
241 |                (compile-form (car pair) env bco #f))
242 |              (lambda ()
243 |                (compile-form (cadr pair) env bco is-tail))
244 |              (lambda ()
245 |                (let ((last-of-form (cddr pair)))
246 |                  (compile-form
247 |                   (if (null? last-of-form)
248 |                       #t
249 |                       (car last-of-form)) env bco is-tail)))))
250 | 
251 | (define (compile-define defined env bco)
252 |   "Compile a toplevel `define` declaration"
253 |   (if (expression-context? env)
254 |       (error 'syntax "declaration \"define\" not \
255 | allowed in expression context"))
256 |   (let ((translated (cdr (translate-define defined))))
257 |     (compile-form (cddr translated) env bco #t)
258 |     (emit
259 |      bco
260 |      'toplevel-set!
261 |      (car translated)))
262 |   (values))
263 | 
264 | (define (compile-function-call function args env bco is-tail)
265 |   "Compile an indirect function call"
266 |   (if (circular-list? args)
267 |       (error 'syntax "Illegal function call"))
268 |   (if (and (pair? function)
269 |            (eq? (cdr function) 'primitive))
270 |       (begin
271 |         (let ((params
272 |                (map (lambda (arg)
273 |                       (let ((val (and (symbol? arg)
274 |                                       (lookup-environment env arg bco))))
275 |                         (if (integer? val)
276 |                             val
277 |                             (begin
278 |                               #;(begin
279 |                               (display "compiling argument: ")
280 |                               (write arg)
281 |                               (newline))
282 |                               (compile-form arg env bco #f)
283 |                               (stack-depth bco)))))
284 |                     args)))
285 |           (apply emit bco (car function) params)))
286 |       (begin
287 |         (emit-load bco function)
288 |         (for-each
289 |          (lambda (x)
290 |            (compile-form x env bco #f)) args)
291 |         (emit bco (if is-tail 'tail-call 'call) (length args))))
292 |   (values))
293 | 
294 | (define (compile-sequence form env bco maybe-tail)
295 |   (if (null? form)
296 |       ;; Scheme defines an empty sequence as an error
297 |       (error 'syntax form "No expressions in sequence")
298 |       (let cont ((current (car form))
299 |                  (next (cdr form)))
300 |         (let ((is-end (null? next)))
301 |           (compile-form current env bco (and maybe-tail is-end))
302 |           (if is-end
303 |               (values)
304 |               (begin
305 |                 (emit bco 'pop)
306 |                 (cont (car next) (cdr next)))))))
307 |   (values))
308 | (define (compile-set! form env bco)
309 |   "Compile an assignment (`set!`)"
310 |   (or (and (proper-list? form)
311 |            (= (length form) 2))
312 |       (error 'syntax "Invalid set!" form))
313 |   (or (symbol? (car form)) (syntax-violation form))
314 |   (compile-form (cadr form) env bco #f)
315 |   (emit-set! bco
316 |              (lookup-environment env (car form) bco))
317 |   (values))
318 | 
319 | ;; Compile a given form to bytecode.
320 | ;;
321 | ;; Quote & self-evaluating forms are added to the constant vector.
322 | ;; Pairs are compiled to function calls and/or expanded specially.
323 | ;;
324 | ;; Return value: the stack index where the return value is located.
325 | (define (compile-form form env bco is-tail?)
326 |   (cond
327 |    ((pair? form) ; Pair = function call OR special form
328 |     (begin (compile-pair form env bco is-tail?) #f))
329 |    ((symbol? form) ; Symbol = variable reference
330 |     (begin (emit-load bco (lookup-environment env form bco)) #f))
331 |    ;; () unquoted is not legal Scheme, but Femtolisp's system.lsp (our stdlib)
332 |    ;; depends on it being self-evaluating.
333 |    ;;((eq? form '())
334 |    ;; (error
335 |    ;;  'syntax
336 |    ;;  "() is not legal Scheme – did you mean '()?" form))
337 |    (else ; Anything else evaluates to itself
338 |     (begin (emit-constant bco form)) #f)))
339 | 
340 | ;;; Compiles a given top-level form to bytecode.
341 | ;;;
342 | ;;; Acts like `compile-form`, except that `define`, `begin`, and `define-macro`
343 | ;;; are handled appropriately for the toplevel.
344 | (define (compile-toplevel-form form env bco)
345 |   (if (pair? form)
346 |       (case (car form)
347 |         ((define)
348 |          (let ((translated (translate-define form)))
349 |            (emit bco 'bind-variable
350 |                  (add-to-constant-vector bco (cadr translated)))
351 |            (compile-form translated env bco #f)))
352 |         ((begin)
353 |          (for-each (lambda (x)
354 |                      (compile-toplevel-form x env bco))
355 |                    (cdr form)))
356 |         ((define-macro)
357 |          (let ((form-to-execute
358 |                 (cdr (translate-define form))))
359 |            (pretty-print (cadr form-to-execute))
360 |            (hash-table-set! (env.macros env)
361 |                             (car form-to-execute)
362 |                             (eval
363 |                              (cadr form-to-execute)
364 |                              (interaction-environment)))))
365 |         (else
366 |          (compile-form form env bco #f)))
367 |       (compile-form form env bco #f)))
368 | 
369 | (define (pp-compiled-form form)
370 |   (let-values (((_ignored bco)
371 |                 (compile-form form (env.new)(create-bco) #t)))
372 |     (pretty-print
373 |      `#(,(vector-copy (bco.instrs bco) 0 (bco.len bco) #f)
374 |         ,(vector-copy (bco.consts bco) 0 (bco.consts-len bco) #f)))))
375 | 


--------------------------------------------------------------------------------
/src/test:
--------------------------------------------------------------------------------
 1 | ||    Compiling RustyScheme v0.1.0 (file:///home/dobenour/repos/RustyScheme)
 2 | value.rs|40 col 53 error| value.rs:40:53: 40:58 error: unresolved name `usize`. Did you mean `size`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~
 3 | value.rs|52 col 14| value.rs:52:14: 52:29 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:53: 40:58 help: run `rustc --explain E0425` to see a detailed explanation
 4 | value.rs|40 col 45 error| value.rs:40:45: 40:52 error: unresolved name `size_of`. Did you mean the macro `size_of!`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~~~
 5 | value.rs|52 col 14| value.rs:52:14: 52:29 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:45: 40:52 help: run `rustc --explain E0425` to see a detailed explanation
 6 | value.rs|40 col 53 error| value.rs:40:53: 40:58 error: unresolved name `usize`. Did you mean `size`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~
 7 | value.rs|55 col 14| value.rs:55:14: 55:29 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:53: 40:58 help: run `rustc --explain E0425` to see a detailed explanation
 8 | value.rs|40 col 45 error| value.rs:40:45: 40:52 error: unresolved name `size_of`. Did you mean the macro `size_of!`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~~~
 9 | value.rs|55 col 14| value.rs:55:14: 55:29 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:45: 40:52 help: run `rustc --explain E0425` to see a detailed explanation
10 | value.rs|40 col 53 error| value.rs:40:53: 40:58 error: unresolved name `usize`. Did you mean `size`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~
11 | value.rs|58 col 14| value.rs:58:14: 58:42 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:53: 40:58 help: run `rustc --explain E0425` to see a detailed explanation
12 | value.rs|40 col 45 error| value.rs:40:45: 40:52 error: unresolved name `size_of`. Did you mean the macro `size_of!`? [E0425] value.rs:40                 end = ((end as usize + size*size_of(usize))+0b111 & !0b111) as *mut Value ^~~~~~~
13 | value.rs|58 col 14| value.rs:58:14: 58:42 note: in this expansion of copy_blocks! (defined in value.rs) value.rs:40:45: 40:52 help: run `rustc --explain E0425` to see a detailed explanation
14 | value.rs|73 col 32 error| value.rs:73:32: 73:39 error: unresolved name `end_ptr` [E0425] value.rs:73             copy_value(i, &mut end_ptr) ^~~~~~~ value.rs:73:32: 73:39 help: run `rustc --explain E0425` to see a detailed explanation
15 | value.rs|77 col 27 error| value.rs:77:27: 77:34 error: unresolved name `tospace`. Did you mean `self.tospace`? [E0425] value.rs:77         let mut current = tospace.as_mut_ptr(); ^~~~~~~ value.rs:77:27: 77:34 help: run `rustc --explain E0425` to see a detailed explanation
16 | value.rs|79 col 30 error| value.rs:79:30: 79:37 error: unresolved name `tospace`. Did you mean `self.tospace`? [E0425] value.rs:79         let end_of_tospace = tospace.as_mut_ptr() as usize + tospace_length; ^~~~~~~ value.rs:79:30: 79:37 help: run `rustc --explain E0425` to see a detailed explanation
17 | value.rs|83 col 39 error| value.rs:83:39: 83:46 error: unresolved name `end_ptr` [E0425] value.rs:83             copy_value(*current, &mut end_ptr); ^~~~~~~ value.rs:83:39: 83:46 help: run `rustc --explain E0425` to see a detailed explanation
18 | value.rs|90 col 29 error| value.rs:90:29: 90:42 error: trait `Allocator` is not in scope [E0405] value.rs:90 pub struct Value<'a, Alloc: Allocator<'a>> { ^~~~~~~~~~~~~ value.rs:90:29: 90:42 help: run `rustc --explain E0405` to see a detailed explanation value.rs:90:29: 90:42 help: you can to import it into scope: `use alloc::Allocator;`.
19 | value.rs|92 col 14 error| value.rs:92:14: 92:36 error: type name `PhantomData` is undefined or not in scope [E0412] value.rs:92     phantom: PhantomData<Alloc<'a>>, ^~~~~~~~~~~~~~~~~~~~~~ value.rs:92:14: 92:36 help: run `rustc --explain E0412` to see a detailed explanation value.rs:92:14: 92:36 help: you can to import it into scope: `use std::marker::PhantomData;`.
20 | value.rs|95 col 28 error| value.rs:95:28: 95:41 error: trait `Allocator` is not in scope [E0405] value.rs:95 pub struct Pair<'a, Alloc: Allocator<'a>> { ^~~~~~~~~~~~~ value.rs:95:28: 95:41 help: run `rustc --explain E0405` to see a detailed explanation value.rs:95:28: 95:41 help: you can to import it into scope: `use alloc::Allocator;`.
21 | value.rs|106 col 9 error| value.rs:106:9: 106:12 error: type name `Int` is undefined or not in scope [E0412] value.rs:106     Int(Int), ^~~ value.rs:106:9: 106:12 help: run `rustc --explain E0412` to see a detailed explanation value.rs:106:9: 106:12 help: no candidates by the name of `Int` found in your project; maybe you misspelled the name or forgot to import an external crate?
22 | value.rs|140 col 6 error| value.rs:140:6: 140:16 error: trait `Add` is not in scope [E0405] value.rs:140 impl Add<Value> for Value { ^~~~~~~~~~ value.rs:140:6: 140:16 help: run `rustc --explain E0405` to see a detailed explanation value.rs:140:6: 140:16 help: you can to import it into scope: `use std::ops::Add;`.
23 | value.rs|147 col 57 error| value.rs:147:57: 147:68 error: type name `SchemeError` is undefined or not in scope [E0412] value.rs:147     pub fn add(&self, other: &mut Self) -> Result<Self, SchemeError> { ^~~~~~~~~~~ value.rs:147:57: 147:68 help: run `rustc --explain E0412` to see a detailed explanation value.rs:147:57: 147:68 help: no candidates by the name of `SchemeError` found in your project; maybe you misspelled the name or forgot to import an external crate?
24 | value.rs|152 col 27 error| value.rs:152:27: 152:51 error: failed to resolve. Use of undeclared type or module `Bignum` [E0433] value.rs:152                 Self::new(Bignum::new_from_fixnums(self.contents, other.contents)) ^~~~~~~~~~~~~~~~~~~~~~~~ value.rs:152:27: 152:51 help: run `rustc --explain E0433` to see a detailed explanation
25 | value.rs|152 col 27 error| value.rs:152:27: 152:51 error: unresolved name `Bignum::new_from_fixnums` [E0425] value.rs:152                 Self::new(Bignum::new_from_fixnums(self.contents, other.contents)) ^~~~~~~~~~~~~~~~~~~~~~~~ value.rs:152:27: 152:51 help: run `rustc --explain E0425` to see a detailed explanation
26 | value.rs|156 col 73 error| value.rs:156:73: 156:82 error: unresolved name `FlonumTag` [E0425] value.rs:156         } else if self.contents.tag = FlonumTag && other.contents.tag = FlonumTag { ^~~~~~~~~ value.rs:156:73: 156:82 help: run `rustc --explain E0425` to see a detailed explanation
27 | value.rs|156 col 39 error| value.rs:156:39: 156:48 error: unresolved name `FlonumTag` [E0425] value.rs:156         } else if self.contents.tag = FlonumTag && other.contents.tag = FlonumTag { ^~~~~~~~~ value.rs:156:39: 156:48 help: run `rustc --explain E0425` to see a detailed explanation
28 | alloc.rs|12 col 44 error| alloc.rs:12:44: 12:49 error: type name `value` is undefined or not in scope [E0412] alloc.rs:12     fn alloc_vector<'b>(&'a mut self, &'b [value]) -> value::Vector<'a>; ^~~~~ alloc.rs:12:44: 12:49 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:12:44: 12:49 help: no candidates by the name of `value` found in your project; maybe you misspelled the name or forgot to import an external crate?
29 | alloc.rs|12 col 55 error| alloc.rs:12:55: 12:72 error: type name `value::Vector` is undefined or not in scope [E0412] alloc.rs:12     fn alloc_vector<'b>(&'a mut self, &'b [value]) -> value::Vector<'a>; ^~~~~~~~~~~~~~~~~ alloc.rs:12:55: 12:72 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:12:55: 12:72 help: no candidates by the name of `Vector` found in your project; maybe you misspelled the name or forgot to import an external crate?
30 | alloc.rs|15 col 60 error| alloc.rs:15:60: 15:75 error: type name `value::Cons` is undefined or not in scope [E0412] alloc.rs:15     fn alloc_pair(&'a mut self, car: Value, cdr: Value) -> value::Cons<'a>; ^~~~~~~~~~~~~~~ alloc.rs:15:60: 15:75 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:15:60: 15:75 help: no candidates by the name of `Cons` found in your project; maybe you misspelled the name or forgot to import an external crate?
31 | alloc.rs|21 col 29 error| alloc.rs:21:29: 21:47 error: type name `value::Closure` is undefined or not in scope [E0412] alloc.rs:21                          -> value::Closure<'a>; ^~~~~~~~~~~~~~~~~~ alloc.rs:21:29: 21:47 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:21:29: 21:47 help: no candidates by the name of `Closure` found in your project; maybe you misspelled the name or forgot to import an external crate?
32 | alloc.rs|25 col 34 error| alloc.rs:25:34: 25:57 error: type name `value::RecordDescriptor` is undefined or not in scope [E0412] alloc.rs:25                     descriptor: &value::RecordDescriptor, ^~~~~~~~~~~~~~~~~~~~~~~ alloc.rs:25:34: 25:57 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:25:34: 25:57 help: no candidates by the name of `RecordDescriptor` found in your project; maybe you misspelled the name or forgot to import an external crate?
33 | alloc.rs|27 col 24 error| alloc.rs:27:24: 27:41 error: type name `value::Record` is undefined or not in scope [E0412] alloc.rs:27                     -> value::Record<'a>; ^~~~~~~~~~~~~~~~~ alloc.rs:27:24: 27:41 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:27:24: 27:41 help: no candidates by the name of `Record` found in your project; maybe you misspelled the name or forgot to import an external crate?
34 | alloc.rs|30 col 55 error| alloc.rs:30:55: 30:75 error: type name `value::HashTable` is undefined or not in scope [E0412] alloc.rs:30     fn alloc_hash_table(&'a mut self, size: usize) -> value::HashTable<'a>; ^~~~~~~~~~~~~~~~~~~~ alloc.rs:30:55: 30:75 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:30:55: 30:75 help: no candidates by the name of `HashTable` found in your project; maybe you misspelled the name or forgot to import an external crate?
35 | alloc.rs|33 col 33 error| alloc.rs:33:33: 33:41 error: type name `io::File` is undefined or not in scope [E0412] alloc.rs:33     fn alloc_port(&'a mut self, io::File) -> value::IOPort; ^~~~~~~~ alloc.rs:33:33: 33:41 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:33:33: 33:41 help: you can to import it into scope: `use std::fs::File;`.
36 | alloc.rs|33 col 46 error| alloc.rs:33:46: 33:59 error: type name `value::IOPort` is undefined or not in scope [E0412] alloc.rs:33     fn alloc_port(&'a mut self, io::File) -> value::IOPort; ^~~~~~~~~~~~~ alloc.rs:33:46: 33:59 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:33:46: 33:59 help: no candidates by the name of `IOPort` found in your project; maybe you misspelled the name or forgot to import an external crate?
37 | alloc.rs|36 col 58 error| alloc.rs:36:58: 36:77 error: type name `value::RustData` is undefined or not in scope [E0412] alloc.rs:36     fn alloc_rustdata<T>(&'a mut self, object: &'a T) -> value::RustData<'a>; ^~~~~~~~~~~~~~~~~~~ alloc.rs:36:58: 36:77 help: run `rustc --explain E0412` to see a detailed explanation alloc.rs:36:58: 36:77 help: no candidates by the name of `RustData` found in your project; maybe you misspelled the name or forgot to import an external crate?
38 | interp.rs|116 col 35 error| interp.rs:116:35: 116:53 error: unresolved name `value::exponential` [E0425] interp.rs:116                 stack[inst.dst] = value::exponential(stack[inst.src], stack[inst.src2]) ^~~~~~~~~~~~~~~~~~ interp.rs:116:35: 116:53 help: run `rustc --explain E0425` to see a detailed explanation
39 | read.rs|16 col 16 error| read.rs:16:16: 16:34 error: failed to resolve. Use of undeclared type or module `state` [E0433] read.rs:16 pub fn read<A: state::SchemeState, R: Read>(state: &mut A, file: R, end_char: char) -> (R, value::Value) { ^~~~~~~~~~~~~~~~~~ read.rs:16:16: 16:34 help: run `rustc --explain E0433` to see a detailed explanation
40 | read.rs|16 col 16 error| read.rs:16:16: 16:34 error: trait `state::SchemeState` is not in scope [E0405] read.rs:16 pub fn read<A: state::SchemeState, R: Read>(state: &mut A, file: R, end_char: char) -> (R, value::Value) { ^~~~~~~~~~~~~~~~~~ read.rs:16:16: 16:34 help: run `rustc --explain E0405` to see a detailed explanation read.rs:16:16: 16:34 help: no candidates by the name of `SchemeState` found in your project; maybe you misspelled the name or forgot to import an external crate?
41 | read.rs|18 col 20 error| read.rs:18:20: 18:36 error: type name `value::Local` is undefined or not in scope [E0412] read.rs:18         InList(Vec<value::Local<'a>>), ^~~~~~~~~~~~~~~~ read.rs:18:20: 18:36 help: run `rustc --explain E0412` to see a detailed explanation read.rs:18:20: 18:36 help: no candidates by the name of `Local` found in your project; maybe you misspelled the name or forgot to import an external crate?
42 | read.rs|19 col 19 error| read.rs:19:19: 19:35 error: type name `value::Local` is undefined or not in scope [E0412] read.rs:19         InVec(Vec<value::Local<'a>>), ^~~~~~~~~~~~~~~~ read.rs:19:19: 19:35 help: run `rustc --explain E0412` to see a detailed explanation read.rs:19:19: 19:35 help: no candidates by the name of `Local` found in your project; maybe you misspelled the name or forgot to import an external crate?
43 | read.rs|43 col 42 error| read.rs:43:42: 43:54 error: unresolved name `value::FALSE` [E0425] read.rs:43                 let new_pair = heap.pair(value::FALSE, ^~~~~~~~~~~~ read.rs:43:42: 43:54 help: run `rustc --explain E0425` to see a detailed explanation
44 | read.rs|45 col 36 error| read.rs:45:36: 45:46 error: unresolved name `local_pair` [E0425] read.rs:45                 current_handle.set(local_pair); ^~~~~~~~~~ read.rs:45:36: 45:46 help: run `rustc --explain E0425` to see a detailed explanation
45 | read.rs|46 col 17 error| read.rs:46:17: 46:29 error: unresolved name `local_handle` [E0425] read.rs:46                 local_handle = heap.pair(state.symbol_table.quote, new_pair); ^~~~~~~~~~~~ read.rs:46:17: 46:29 help: run `rustc --explain E0425` to see a detailed explanation
46 | read.rs|74 col 42 error| read.rs:74:42: 74:52 error: unresolved name `map_escape` [E0425] read.rs:74                         string.push(try!(map_escape(try!(x.next.map_err())))) ^~~~~~~~~~
47 | read.rs|74 col 37| read.rs:74:37: 74:77 note: in this expansion of try! (defined in <std macros>) read.rs:74:42: 74:52 help: run `rustc --explain E0425` to see a detailed explanation
48 | value.rs|17 col 18 error| value.rs:17:18: 17:23 error: wrong number of lifetime parameters: expected 1, found 0 [E0107] value.rs:17     tospace: Vec<Value>, ^~~~~ value.rs:17:18: 17:23 help: run `rustc --explain E0107` to see a detailed explanation
49 | value.rs|17 col 18 error| value.rs:17:18: 17:23 error: wrong number of type arguments: expected 1, found 0 [E0243] value.rs:17     tospace: Vec<Value>, ^~~~~ value.rs:17:18: 17:23 help: run `rustc --explain E0243` to see a detailed explanation
50 | value.rs|18 col 20 error| value.rs:18:20: 18:25 error: wrong number of lifetime parameters: expected 1, found 0 [E0107] value.rs:18     fromspace: Vec<Value>, ^~~~~ value.rs:18:20: 18:25 help: run `rustc --explain E0107` to see a detailed explanation
51 | value.rs|18 col 20 error| value.rs:18:20: 18:25 error: wrong number of type arguments: expected 1, found 0 [E0243] value.rs:18     fromspace: Vec<Value>, ^~~~~ value.rs:18:20: 18:25 help: run `rustc --explain E0243` to see a detailed explanation
52 | value.rs|19 col 20 error| value.rs:19:20: 19:25 error: wrong number of lifetime parameters: expected 1, found 0 [E0107] value.rs:19     pub stack: Vec<Value>, ^~~~~ value.rs:19:20: 19:25 help: run `rustc --explain E0107` to see a detailed explanation
53 | value.rs|19 col 20 error| value.rs:19:20: 19:25 error: wrong number of type arguments: expected 1, found 0 [E0243] value.rs:19     pub stack: Vec<Value>, ^~~~~ value.rs:19:20: 19:25 help: run `rustc --explain E0243` to see a detailed explanation
54 | value.rs|34 col 36 error| value.rs:34:36: 34:41 error: wrong number of type arguments: expected 1, found 0 [E0243] value.rs:34 unsafe fn copy_value(current: &mut Value, end: &mut *mut Value) { ^~~~~ value.rs:34:36: 34:41 help: run `rustc --explain E0243` to see a detailed explanation
55 | value.rs|34 col 58 error| value.rs:34:58: 34:63 error: wrong number of type arguments: expected 1, found 0 [E0243] value.rs:34 unsafe fn copy_value(current: &mut Value, end: &mut *mut Value) { ^~~~~ value.rs:34:58: 34:63 help: run `rustc --explain E0243` to see a detailed explanation
56 | || error: cannot continue compilation due to previous error
57 | || Could not compile `RustyScheme`.
58 | || 
59 | || To learn more, run the command again with --verbose.
60 | 


--------------------------------------------------------------------------------
/src/read.rs:
--------------------------------------------------------------------------------
  1 | use std::io;
  2 | use std::io::prelude::*;
  3 | use std::char;
  4 | use std::iter::Peekable;
  5 | use super::interp;
  6 | use super::api;
  7 | #[derive(Debug)]
  8 | pub enum ReadError {
  9 |     /// EOF in list
 10 |     EOFInList,
 11 | 
 12 |     /// EOF in vector
 13 |     EOFInVector,
 14 | 
 15 |     /// Missing `)`
 16 |     MissingCloseParen,
 17 | 
 18 |     /// Input/output error
 19 |     IoError(io::Error),
 20 | 
 21 |     /// EOF in string
 22 |     EOFInString,
 23 | 
 24 |     /// EOF in symbol
 25 |     EOFInSymbol,
 26 | 
 27 |     /// EOF after `#\\`
 28 |     EOFAfterSharpBackslash,
 29 | 
 30 |     /// Bad sharpsign read macro
 31 |     BadSharpMacro([char; 2]),
 32 | 
 33 |     /// Unexpected close parentheses
 34 |     UnexpectedCloseParen,
 35 | 
 36 |     /// Wrong close parentheses
 37 |     BadCloseParen,
 38 | 
 39 |     /// Bad backslash escape
 40 |     BadEscape,
 41 | 
 42 |     /// EOF after sharpsign
 43 |     EOFAfterSharp,
 44 | 
 45 |     /// Stream not valid UTF-8.  The argument is
 46 |     /// the partial sequence accumulated.
 47 |     InvalidUtf8(u32),
 48 | 
 49 |     /// `|` in symbol unescaped
 50 |     PipeInSymbol,
 51 | 
 52 |     /// Bad hex number
 53 |     BadHexNumber,
 54 | 
 55 |     /// Integer overflow
 56 |     Overflow,
 57 | 
 58 |     /// Bad use of `.`
 59 |     BadDot,
 60 | 
 61 |     /// Mismatched parentheses
 62 |     ParenMismatch,
 63 | 
 64 |     /// Host-set memory limit exceeded
 65 |     MemLimitExceeded,
 66 | 
 67 |     /// Not yet implemented
 68 |     NYI,
 69 | }
 70 | 
 71 | /// An event that can be emitted by the reader or tree-walker, and which
 72 | /// is part of the stream that is consumed by the tree-builder, printer,
 73 | /// and bytecode compiler.
 74 | #[derive(Clone, Debug)]
 75 | pub enum Event {
 76 |     /// A string
 77 |     Str(String),
 78 | 
 79 |     /// A symbol
 80 |     Symbol(String),
 81 | 
 82 |     /// Boolean true `#t`
 83 |     True,
 84 | 
 85 |     /// Boolean false `#f`
 86 |     False,
 87 | 
 88 |     /// Character `#\\x`
 89 |     Char(char),
 90 | 
 91 |     /// Integer `12311324`
 92 |     Int(usize),
 93 | 
 94 |     /// Floating-point numbers (not yet implemented)
 95 |     Float(f64),
 96 | 
 97 |     /// Start of a list `(` (false) or `[` (true)
 98 |     StartList(bool),
 99 | 
100 |     /// Start of a vector `#(`
101 |     StartVec,
102 | 
103 |     /// End of token `)` (false) or `]` (true)
104 |     EndList(bool),
105 | 
106 |     /// Read-time eval `#.`
107 |     ReadEval,
108 | 
109 |     /// Quote `'`
110 |     Quote,
111 | 
112 |     /// Quasiquote `\``
113 |     Quasiquote,
114 | 
115 |     /// Unquote `,`
116 |     Unquote,
117 | 
118 |     /// Unquote splicing `,@`
119 |     UnquoteSplicing,
120 | 
121 |     /// Syntax `#'`
122 |     Syntax,
123 | 
124 |     /// Quasisyntax `#\``
125 |     Quasisyntax,
126 | 
127 |     /// Unsyntax `#,`
128 |     Unsyntax,
129 | 
130 |     /// Unsyntax splicing #,@
131 |     UnsyntaxSplicing,
132 | 
133 |     /// Dot `.`
134 |     Dot,
135 | 
136 |     /// End of file
137 |     EOF,
138 | }
139 | 
140 | #[derive(PartialEq, Eq, Copy, Clone, Debug)]
141 | enum StringOrSymbol {
142 |     String,
143 |     Symbol,
144 | }
145 | use self::ReadError::IoError;
146 | fn finish_char<R: BufRead>(file: &mut Peekable<Bytes<R>>,
147 |                            unicode_char: u8)
148 |                            -> Result<char, ReadError> {
149 |     if unicode_char <= 0x7F {
150 |         return Ok(unicode_char as char);
151 |     }
152 |     let len = (!unicode_char).leading_zeros() as u8;
153 |     match len {
154 |         1 | 5...8 => Err(ReadError::InvalidUtf8((unicode_char as u32) << 24)),
155 |         len @ 2...4 => {
156 |             let len = len - 1;
157 |             let mut value: u32 = (unicode_char >> (len + 2)).into();
158 |             value <<= len * 6;
159 |             for (count, val) in &mut file.take(len.into()).enumerate() {
160 |                 value &= (try!(val.map_err(IoError)) as u32) << (len - count as u8)
161 |             }
162 |             char::from_u32(value).ok_or_else(|| ReadError::InvalidUtf8(value))
163 |         }
164 |         _ => unreachable!(),
165 |     }
166 | }
167 | macro_rules! next {
168 |     ($exp: expr, $err: expr) => {
169 |         try!(try!($exp.next().ok_or($err)).map_err(ReadError::IoError))
170 |     }
171 | }
172 | 
173 | type ReadResult = Result<char, ReadError>;
174 | 
175 | use std::io::Bytes;
176 | fn handle_unicode_escape<R: BufRead>(file: &mut Peekable<Bytes<R>>) -> ReadResult {
177 |     loop {
178 |         let eof = ReadError::BadEscape;
179 |         let mut escaped_char = 0;
180 |         let next_character = next!(file, eof);
181 |         let subtract_amount = match next_character {
182 |             b'a'...b'f' => 87,
183 |             b'A'...b'F' => 55,
184 |             b'0'...b'9' => 48,
185 |             b';' => return char::from_u32(escaped_char).ok_or(ReadError::BadEscape),
186 |             _ => return Err(ReadError::BadEscape),
187 |         };
188 |         escaped_char <<= 4;
189 |         // No overflow is possible here – later check would
190 |         // detect it.
191 |         escaped_char += next_character as u32 - subtract_amount;
192 |         if escaped_char > 0x10FFFF {
193 |             // protect against overflow
194 |             return Err(ReadError::BadEscape);
195 |         }
196 |     }
197 | }
198 | 
199 | fn process_escape<R: BufRead>(file: &mut Peekable<Bytes<R>>) -> ReadResult {
200 |     let bad = ReadError::BadEscape;
201 |     loop {
202 |         return Ok(match next!(file, ReadError::BadEscape) {
203 |             b'n' => '\n',
204 |             b't' => '\t',
205 |             b'e' => '\x1b',
206 |             b'b' => '\x08',
207 |             b'v' => '\x0b',
208 |             b'f' => '\x0c',
209 |             b'\r' => {
210 |                 match file.next() {
211 |                     Some(Ok(b'\n')) => continue,
212 |                     Some(Ok(_)) | None => return Err(bad),
213 |                     Some(Err(x)) => return Err(ReadError::IoError(x)),
214 |                 }
215 |             }
216 |             b'\n' => continue,
217 |             b'x' | b'u' => try!(handle_unicode_escape(file)),
218 |             l @ b'|' | l @ b'"' | l @ b'\\' | l @ b'#' | l @ b'`' | l @ b',' | l @ b'\'' => {
219 |                 l as char
220 |             }
221 |             _ => return Err(bad),
222 |         });
223 |     }
224 | }
225 | 
226 | 
227 | 
228 | fn read_escaped<R: BufRead>(file: &mut Peekable<Bytes<R>>,
229 |                             delimiter: StringOrSymbol)
230 |                             -> Result<String, ReadError> {
231 |     let premature_eof = || {
232 |         match delimiter {
233 |             StringOrSymbol::String => ReadError::EOFInString,
234 |             StringOrSymbol::Symbol => ReadError::EOFInSymbol,
235 |         }
236 |     };
237 | 
238 |     let mut buf = String::new();
239 |     loop {
240 |         buf.push(match next!(file, premature_eof()) {
241 |             b'\\' => try!(process_escape(file)),
242 |             b'|' if delimiter == StringOrSymbol::Symbol => break,
243 |             b'"' if delimiter == StringOrSymbol::String => break,
244 |             normal_char => try!(finish_char(file, normal_char)),
245 |         })
246 |     }
247 |     Ok(buf)
248 | }
249 | 
250 | pub struct Reader<'a, 'b, T: 'a + BufRead> {
251 |     stream: &'a mut T,
252 |     state: &'b mut interp::State,
253 | }
254 | 
255 | pub struct EventSource<'a, R: 'a + BufRead> {
256 |     file: &'a mut Peekable<Bytes<R>>,
257 |     last_chr: Option<u8>,
258 | }
259 | 
260 | macro_rules! my_try {
261 |     ($exp: expr) => {
262 |         match $exp {
263 |             Ok(x) => x,
264 |             Err(x) => return Some(Err(x)),
265 |         }
266 |     }
267 | }
268 | macro_rules! iter_next {
269 |     ($exp: expr, $err: expr) => {
270 |         my_try!(
271 |             my_try!($exp.next().ok_or($err)).map_err(ReadError::IoError))
272 |     }
273 | }
274 | 
275 | type Item<'a, R> = <EventSource<'a, R> as Iterator>::Item;
276 | type ItemOption<'a, R> = Option<Item<'a, R>>;
277 | 
278 | 
279 | impl<'a, R: BufRead> EventSource<'a, R> {
280 |     pub fn new(reader: &'a mut Peekable<Bytes<R>>) -> Self {
281 |         EventSource {
282 |             file: reader,
283 |             last_chr: Default::default(),
284 |         }
285 |     }
286 | 
287 |     fn handle_splicing(&mut self, nosplice: Event, splice: Event) -> Item<R> {
288 |         match self.file.next() {
289 |             Some(Ok(b'@')) => Ok(splice),
290 |             Some(Ok(l)) => {
291 |                 self.last_chr = Some(l);
292 |                 Ok(nosplice)
293 |             }
294 |             None => {
295 |                 self.last_chr = None;
296 |                 Ok(nosplice)
297 |             }
298 |             Some(Err(a)) => Err(ReadError::IoError(a)),
299 |         }
300 |     }
301 |     fn read_hex(&mut self) -> Item<R> {
302 |         let mut buf = String::new();
303 |         for i in &mut self.file {
304 |             match try!(i.map_err(ReadError::IoError)) {
305 |                 i @ b'0'...b'9' | i @ b'A'...b'F' | i @ b'a'...b'f' => buf.push(i as char),
306 |                 _ => return Err(ReadError::BadHexNumber),
307 |             }
308 |         }
309 |         if let Ok(x) = buf.parse() {
310 |             Ok(Event::Int(x))
311 |         } else {
312 |             Err(ReadError::Overflow)
313 |         }
314 |     }
315 |     fn process_sharpsign(&mut self) -> ItemOption<R> {
316 |         Some(Ok(match iter_next!(self.file, ReadError::EOFAfterSharp) {
317 |             b'.' => Event::ReadEval,
318 |             b'\\' => {
319 |                 let byte = iter_next!(self.file, ReadError::EOFAfterSharpBackslash);
320 |                 Event::Char(my_try!(finish_char(self.file, byte)))
321 |             }
322 |             b't' => Event::True,
323 |             b'f' => Event::False,
324 |             b'x' => my_try!(self.read_hex()),
325 |             b'\'' => Event::Syntax,
326 |             b'`' => Event::Quasisyntax,
327 |             b',' => my_try!(self.handle_splicing(Event::Unsyntax, Event::UnsyntaxSplicing)),
328 |             b'(' => Event::StartVec,
329 |             dispatch_char => {
330 |                 return Some(Err(ReadError::BadSharpMacro([dispatch_char as char, '\0'])))
331 |             }
332 |         }))
333 |     }
334 |     #[cfg_attr(feature = "clippy", allow(while_let_on_iterator))]
335 |     fn read_symbol(&mut self, start: char) -> Result<Event, ReadError> {
336 |         let mut buf = String::new();
337 |         buf.push(start);
338 |         while let Some(x) = self.file.next() {
339 |             match try!(x.map_err(ReadError::IoError)) {
340 |                 b'\\' => buf.push(try!(process_escape(self.file))),
341 |                 b'|' => return Err(ReadError::PipeInSymbol),
342 |                 a @ b'"' |
343 |                 a @ b'\'' |
344 |                 a @ b'`' |
345 |                 a @ b',' |
346 |                 a @ b'(' |
347 |                 a @ b'[' |
348 |                 a @ b']' |
349 |                 a @ b')' |
350 |                 a @ b'{' |
351 |                 a @ b'}' => {
352 |                     self.last_chr = Some(a);
353 |                     break;
354 |                 }
355 |                 b'\t'...b'\r' | b' ' => break, // ASCII whitespace
356 |                 chr => {
357 |                     let unicode_char = try!(finish_char(self.file, chr));
358 |                     if unicode_char.is_whitespace() {
359 |                         break;
360 |                     }
361 |                     buf.push(unicode_char)
362 |                 }
363 |             }
364 |         }
365 |         Ok(if &buf == "." {
366 |             Event::Dot
367 |         } else {
368 |             Event::Symbol(buf)
369 |         })
370 |     }
371 | }
372 | 
373 | 
374 | impl<'a, R: BufRead> Iterator for EventSource<'a, R> {
375 |     type Item = Result<Event, ReadError>;
376 |     fn next(&mut self) -> Option<<Self as Iterator>::Item> {
377 |         loop {
378 |             let chr = if let Some(chr) = self.last_chr {
379 |                 self.last_chr = None;
380 |                 chr
381 |             } else {
382 |                 let next: Option<Result<u8, io::Error>> = self.file.next();
383 |                 if let Some(c) = next {
384 |                     my_try!(c.map_err(ReadError::IoError))
385 |                 } else {
386 |                     return None;
387 |                 }
388 |             };
389 |             return Some(Ok(match chr {
390 |                 b'(' => Event::StartList(false),
391 |                 b'[' => Event::StartList(true),
392 |                 b'\'' => Event::Quote,
393 |                 b'`' => Event::Quasiquote,
394 |                 b',' => my_try!(self.handle_splicing(Event::Unquote, Event::UnquoteSplicing)),
395 |                 b'#' => return self.process_sharpsign(),
396 |                 b')' => Event::EndList(false),
397 |                 b']' => Event::EndList(true),
398 |                 b'"' => Event::Str(my_try!(read_escaped(self.file, StringOrSymbol::String))),
399 |                 b'|' => Event::Symbol(my_try!(read_escaped(self.file, StringOrSymbol::Symbol))),
400 |                 b'\t'...b'\r' | b' ' => continue, // ASCII whitespace
401 |                 val => {
402 |                     let chr = if val < 0x7F {
403 |                         val as char
404 |                     } else {
405 |                         my_try!(finish_char(self.file, val))
406 |                     };
407 |                     if chr.is_whitespace() {
408 |                         continue;
409 |                     }
410 |                     return Some(self.read_symbol(chr));
411 |                 }
412 |             }));
413 |         }
414 |     }
415 | }
416 | 
417 | pub fn read<R: BufRead>(s: &mut api::State, r: &mut Peekable<Bytes<R>>) -> Result<(), ReadError> {
418 |     #[derive(Copy, Clone, Debug)]
419 |     enum State {
420 |         List {
421 |             is_square: bool,
422 |             depth: usize,
423 |         },
424 |         DottedList {
425 |             is_square: bool,
426 |             depth: usize,
427 |         },
428 |         Vec {
429 |             depth: usize,
430 |         },
431 |         ReaderMacro,
432 |     }
433 |     let mut read_stack: Vec<State> = Vec::new();
434 |     let mut source = EventSource::new(r);
435 |     loop {
436 |         let i = match source.next() {
437 |             None => return Ok(()),
438 |             Some(x) => x,
439 |         };
440 |         match try!(i) {
441 |             Event::Char(_) => unimplemented!(),
442 |             Event::Int(x) => {
443 |                 s.push(x).unwrap();
444 |                 // try!(execute_macros(source))
445 |             }
446 |             Event::Str(st) => {
447 |                 s.push(st).unwrap();
448 |                 // try!(execute_macros(source))
449 |             }
450 |             Event::Symbol(st) => {
451 |                 s.intern(&st).unwrap();
452 |                 // try!(execute_macros(source))
453 |             }
454 |             Event::Dot => {
455 |                 let len = read_stack.len().wrapping_sub(1);
456 |                 if let Some(x) = read_stack.get_mut(len) {
457 |                     match *x {
458 |                         State::List { depth, is_square } => {
459 |                             *x = State::DottedList {
460 |                                 depth: depth,
461 |                                 is_square: is_square,
462 |                             };
463 |                             continue
464 |                         }
465 |                         _ => return Err(ReadError::BadDot),
466 |                     }
467 |                 } else {
468 |                     return Err(ReadError::BadDot);
469 |                 }
470 |                 continue;
471 |             }
472 |             Event::EndList(is_square) => {
473 |                 if let Some(state) = read_stack.pop() {
474 |                     match state {
475 |                         State::DottedList { .. } | State::ReaderMacro =>
476 |                             return Err(ReadError::UnexpectedCloseParen),
477 |                         State::Vec { depth } => {
478 |                             debug_assert!(depth > 0);
479 |                             if is_square {
480 |                                 return Err(ReadError::BadCloseParen)
481 |                             } else {
482 |                                 s.vector(1, depth).expect("Out of mem!")
483 |                             }
484 |                         }
485 |                         State::List { is_square: square, depth } => {
486 |                             if square == is_square {
487 |                                 s.list(depth).expect("Out of mem!")
488 |                             } else {
489 |                                 return Err(ReadError::BadCloseParen)
490 |                             }
491 |                         }
492 |                     }
493 |                 } else {
494 |                     return Ok(())
495 |                 }
496 |             }
497 |             Event::StartVec => {
498 |                 read_stack.push(State::Vec { depth: 0 });
499 |                 continue;
500 |             }
501 |             Event::StartList(x) => {
502 |                 read_stack.push(State::List {
503 |                     is_square: x,
504 |                     depth: 0,
505 |                 });
506 |                 continue;
507 |             }
508 |             Event::Quote => {
509 |                 try!(s.push("quote".to_owned()).map_err(|()| ReadError::MemLimitExceeded));
510 |                 read_stack.push(State::ReaderMacro);
511 |                 continue;
512 |             }
513 |             Event::Quasiquote => {
514 |                 try!(s.push("backquote".to_owned()).map_err(|()| ReadError::MemLimitExceeded));
515 |                 read_stack.push(State::ReaderMacro);
516 |                 continue;
517 |             }
518 |             Event::Unquote => {
519 |                 try!(s.push("unquote".to_owned()).map_err(|()| ReadError::MemLimitExceeded));
520 |                 read_stack.push(State::ReaderMacro);
521 |                 continue;
522 |             }
523 |             _ => return Err(ReadError::NYI),
524 |         }
525 |         let last = read_stack.len().wrapping_sub(1);
526 |         if let Some(&x) = read_stack.get(last) {
527 |             match x {
528 |                 State::ReaderMacro => {
529 |                     try!(s.list(2).map_err(|_| ReadError::MemLimitExceeded));
530 |                     read_stack.pop();
531 |                 }
532 |                 State::List { depth, is_square } => {
533 |                     read_stack[last] = State::List {
534 |                         depth: depth + 1,
535 |                         is_square: is_square,
536 |                     }
537 |                 }
538 |                 State::Vec { depth } => {
539 |                     read_stack[last] = State::Vec {
540 |                         depth: depth + 1,
541 |                     }
542 |                 }
543 |                 State::DottedList { depth, is_square } => {
544 |                     try!(s.list_with_tail(depth).map_err(|_| ReadError::MemLimitExceeded));
545 |                     if let Some(token) = source.next() {
546 |                         debug!("Token that must be close paren: {:?}\n", token);
547 |                         match try!(token) {
548 |                             Event::EndList(x) if x == is_square => continue,
549 |                             Event::EndList(_) => return Err(ReadError::ParenMismatch),
550 |                             _ => return Err(ReadError::MissingCloseParen),
551 |                         }
552 |                     } else {
553 |                         s.drop().expect("Empty stack after list_with_tail?");
554 |                         return Err(ReadError::BadDot);
555 |                     }
556 |                 }
557 |             }
558 |         } else {
559 |             return Ok(());
560 |         }
561 |     }
562 | }
563 | 
564 | #[cfg(test)]
565 | mod test {
566 |     use std::io::Read;
567 |     use env_logger;
568 |     use api;
569 |     #[test]
570 |     fn read_from_bytes() {
571 |         let _ = env_logger::init();
572 |         let mut interp = api::State::new();
573 |         let iter = b"(a b c . d)";
574 |         super::read(&mut interp, &mut iter.bytes().peekable()).unwrap();
575 |         assert_eq!(interp.len(), 1);
576 |     }
577 | 
578 |     #[test]
579 |     fn read_to_vec() {
580 |         let _ = env_logger::init();
581 |         let mut interp = api::State::new();
582 |         let mut iter = b"#(a b c d)".bytes().peekable();
583 |         super::read(&mut interp, &mut iter).unwrap();
584 |     }
585 | }
586 | 


--------------------------------------------------------------------------------
/src/alloc/mod.rs:
--------------------------------------------------------------------------------
  1 | //! # The RustyScheme memory allocator and garbage collector.
  2 | //!
  3 | //! This module contains the `RustyScheme` allocator and garbage collector.
  4 | //! The collector is a simple, two-space copying collector using Cheney's
  5 | //! algorithm.
  6 | //!
  7 | //! ## Finalizer support
  8 | //!
  9 | //! Finalizers for custom objects are supported by:
 10 | //!
 11 | //! 1. Create an intrusive linked list of objects with finalizers.
 12 | //! 2. During GC, do not relocate the finalizer list pointers.
 13 | //! 3. After the main GC, traverse the list of object with finalizers.
 14 | //!    Relocate the pointers that point to forwarding pointers.  Execute
 15 | //!    the finalizers of other (unreachable) objects.
 16 | //!
 17 | //! ## Object layout
 18 | //!
 19 | //! All objects in the garbage collected heap begin with a header.  The top
 20 | //! 3 bits of the header indicate the type of the object.  The remaining 3 bits
 21 | //! indicate the object's size in machine words.  Thus, objects are limited to
 22 | //! 2GiB on a 32-bit system, but there is no limit (other than available memory)
 23 | //! on 64-bit systems.
 24 | //!
 25 | //! All heap objects must be at least 2 words long.  The second word is
 26 | //! overwritten with a forwarding pointer during GC.
 27 | //!
 28 | //! Vectors have header tag 0.
 29 | //! TODO finish this.
 30 | 
 31 | extern crate libc;
 32 | use std::fs::File;
 33 | use std::mem;
 34 | use std::ptr;
 35 | use std::slice;
 36 | use super::value;
 37 | use value::{Value, SIZEOF_PAIR, HEADER_TAG, SYMBOL_TAG, Kind};
 38 | use symbol;
 39 | use bytecode;
 40 | 
 41 | mod debug;
 42 | 
 43 | //mod iter;
 44 | /// An allocator for `RustyScheme` objects
 45 | pub trait Allocator {
 46 |     /// Allocates a vector
 47 |     fn alloc_vector(&mut self, &[Value]) -> value::Vector;
 48 | 
 49 |     /// Allocates a pair
 50 |     fn alloc_pair(&mut self, car: Value, cdr: Value);
 51 | 
 52 |     /// Allocates a closure
 53 |     fn alloc_closure(&mut self, bytecode: &value::BCO, upvalues: &[Value]) -> value::Closure;
 54 | 
 55 |     /// Allocates a record
 56 |     fn alloc_record(&mut self,
 57 |                     descriptor: &value::RecordDescriptor,
 58 |                     fields: &[Value])
 59 |                     -> value::Record;
 60 | 
 61 |     /// Allocates a hash table
 62 |     fn alloc_hash_table(&mut self, size: usize) -> value::HashTable;
 63 | 
 64 |     /// Allocates a port
 65 |     fn alloc_port(&mut self, File) -> value::IOPort;
 66 | 
 67 |     /// Allocates a rustdata, which contains an arbitrary Rust object
 68 |     fn alloc_rustdata<T>(&mut self, object: &T) -> value::RustData;
 69 | 
 70 |     // /// Allocates a boxed float on the top of the stack.
 71 |     // fn alloc_float(&mut self, float: f64) -> value::Float;
 72 | }
 73 | 
 74 | const PAIR: usize = value::HeaderTag::Pair as usize;
 75 | const RUSTDATA: usize = value::HeaderTag::RustData as usize;
 76 | const VECTOR: usize = value::HeaderTag::Vector as usize;
 77 | const BYTECODE: usize = value::HeaderTag::Bytecode as usize;
 78 | 
 79 | /// An instance of the garbage-collected Scheme heap.
 80 | #[derive(Debug)]
 81 | pub struct Heap {
 82 |     /// The symbol table
 83 |     pub symbol_table: symbol::SymbolTable,
 84 | 
 85 |     /// The tospace.
 86 |     tospace: Vec<Value>,
 87 | 
 88 |     /// The fromspace.
 89 |     fromspace: Vec<Value>,
 90 |     /// The environment of the current closure.
 91 |     pub environment: *mut value::Vector,
 92 | 
 93 |     /// The constants vector of the current closure.
 94 |     pub constants: *const value::Vector,
 95 | 
 96 |     /// The execution stack.
 97 |     pub stack: self::Stack,
 98 | 
 99 |     /// The approximate amount of memory used last
100 |     last_mem_use: usize
101 | }
102 | 
103 | #[repr(packed)]
104 | pub struct FinalizedObject {
105 |     /// The standard header
106 |     header: usize,
107 | 
108 |     /// Size of user struct
109 |     user_struct_size: usize,
110 | 
111 |     /// Number of associated fields
112 |     private_fields: usize,
113 | 
114 |     /// Link in finalized object chain
115 |     link: *const FinalizedObject,
116 | 
117 |     /// User payload
118 |     payload: Drop,
119 | }
120 | 
121 | use std::cell;
122 | 
123 | /// A GC root.
124 | ///
125 | /// A `Root` is a handle to an object on the garbage-collected Scheme heap.
126 | /// The Scheme garbage collector knows about `Root`s, and ensures that they
127 | /// stay valid even when a garbage collection occurs.  Therefore, client code
128 | /// must use `Root`s (or the stack) to store all references to Scheme data.
129 | ///
130 | /// There are 2 types of `Root`: local roots and persistent roots.  A local
131 | /// root can only be created from within a callback from the VM and is stack
132 | /// allocated.  A global root can be created by any code that has a valid
133 | /// reference to the VM, and may live for as long as the VM is alive.  Global
134 | /// roots are more expensive in terms of VM resources (they are stored in a
135 | /// heap-allocated data structure), but are not limited by a scope.
136 | #[derive(Debug)]
137 | pub struct Root<'a> {
138 |     contents: &'a cell::UnsafeCell<Value>,
139 | }
140 | 
141 | /// Rounds the size of a heap object up to the nearest multiple of 8 bytes,
142 | /// expressed in words.
143 | fn align_word_size(size: usize) -> usize {
144 |     let size_of_value = ::std::mem::size_of::<Value>();
145 |     debug_assert!((!0b1usize).wrapping_add(2) == 0);
146 |     let x = match size_of_value {
147 |         4 => (size + 1) & !0b1,
148 |         8 => size,
149 |         _ => ((size * size_of_value + 0b111) & !0b111) / size_of_value,
150 |     };
151 |     debug_assert!((x + 1) & !1 >= x);
152 |     // assert!(x - size_of_value <= 1);
153 |     x
154 | }
155 | 
156 | /// Relocates a `Value` in the heap.
157 | ///
158 | /// This function relocates a `Value` in the Scheme heap.  It takes two
159 | /// arguments: `current`, the `Value` being relocated, and `end`, the current
160 | /// end of tospace.
161 | ///
162 | /// This function takes raw pointers because of aliasing concerns.
163 | unsafe fn relocate(current: *mut Value, tospace: &mut Vec<Value>, fromspace: &mut Vec<Value>) {
164 |     debug_assert!(tospace.capacity() >= fromspace.len());
165 |     if false {
166 |         debug!("Tospace capacity: {}, Fromspace length: {}",
167 |                tospace.capacity(),
168 |                fromspace.len());
169 |     }
170 |     let size_of_value: usize = size_of!(Value);
171 |     (*current).size().map(|size| {
172 |         if size == 0 && (*current).tag() == value::Tags::Symbol {
173 |             // Symbols.
174 |             // These need to be treated specially, since they are not copied.
175 |             let mut current = current;
176 |             let mut chain_length = 0;
177 |             loop {
178 |                 let ptr = (*current).as_ptr() as *mut symbol::Symbol;
179 |                 if (*ptr).alive.get() { return }
180 |                 chain_length += 1;
181 |                 (*ptr).alive.set(true);
182 |                 current = (*ptr).contents.get();
183 |                 if (*current).tag() != value::Tags::Symbol {
184 |                     debug!("Current: current = {:p}, *current = {:x}",
185 |                            current,
186 |                            (*current).get());
187 |                     debug!("Chain length: {}", chain_length);
188 |                     return relocate(current, tospace, fromspace)
189 |                 }
190 |             }
191 |         }
192 |         // pointer to head of object being copied
193 |         let pointer: *mut Value = (*current).as_ptr();
194 | 
195 |         //debug!("HEADER_TAG is {:b}\n", HEADER_TAG);
196 | 
197 |         let header = (*pointer).get();
198 |         // Assert that the object header is nonzero.
199 |         debug_assert!(header != 0,
200 |                       "internal error: copy_value: invalid object header size");
201 |         if header & HEADER_TAG == HEADER_TAG {
202 |             debug_assert!(header == HEADER_TAG, "Bad header: {ptr:x}\n", ptr = header);
203 |             // Forwarding pointer detected (this header tag is otherwise absurd,
204 |             // since no object can have a size of zero).
205 |             *current = (&*pointer.offset(1)).clone()
206 |         } else {
207 |             let len = tospace.len();
208 | 
209 |             // End pointer
210 |             let end = tospace.as_mut_ptr().offset(len as isize);
211 | 
212 |             let amount_to_copy = align_word_size(size);
213 | 
214 |             // Check that the amount to copy is reasonable
215 |             debug_assert!(amount_to_copy > 0,
216 |                           "internal error: relocate: zero-sized word");
217 | 
218 |             // Check that the end pointer is aligned
219 |             debug_assert!(end as usize & 0b111 == 0,
220 |                           "internal error: relocate: misaligned end pointer");
221 | 
222 |             // Check that the pointer really is to fromspace
223 |             debug_assert!((pointer as usize) <
224 |                           fromspace.as_ptr() as usize + fromspace.len() * size_of!(usize),
225 |                           "internal error: relocate: attempt to relocate pointer not to fromspace");
226 |             debug_assert!(pointer as usize >= fromspace.as_ptr() as usize);
227 | 
228 |             if cfg!(feature = "memcpy-gc") {
229 |                 let words_to_copy = amount_to_copy * size_of_value;
230 |                 // The amount to copy
231 |                 debug_assert!(amount_to_copy + len <= tospace.capacity());
232 |                 debug_assert!(pointer as usize >= end as usize + words_to_copy ||
233 |                               pointer as usize + words_to_copy <= end as usize);
234 |                 // NOTE: reverse pointer argument order from `memcpy`.
235 |                 ptr::copy_nonoverlapping(pointer, end, amount_to_copy);
236 |                 tospace.set_len(len + amount_to_copy)
237 |             } else {
238 |                 // NOTE: this MUST come before replacing the old object with
239 |                 // a forwarding pointer – otherwise, this replacement will
240 |                 // clobber the copied object's header!
241 |                 tospace.extend_from_slice(slice::from_raw_parts(pointer,
242 |                                                                 amount_to_copy));
243 |             }
244 |             *pointer = Value::new(HEADER_TAG);
245 |             *current = Value::new(end as usize | ((*current).get() & 0b111));
246 |             *pointer.offset(1) = (*current).clone();
247 |         }
248 |     });
249 | }
250 | 
251 | /// Process the heap.
252 | unsafe fn scavange_heap(tospace: &mut Vec<Value>, fromspace: &mut Vec<Value>) {
253 |     let mut offset: isize = 0;
254 |     use std::isize;
255 |     assert!(tospace.len() <= isize::MAX as usize);
256 |     assert!(fromspace.len() <= isize::MAX as usize);
257 |     let current = tospace.as_mut_ptr();
258 |     while offset < tospace.len() as isize {
259 |         let header = (*current.offset(offset)).get();
260 |         let size = header & !HEADER_TAG;
261 |         let tag = header & HEADER_TAG;
262 |         assert!(size > 0);
263 |         offset += 1;
264 |         match tag {
265 |             value::HEADER_TAG => /* Forwarding pointer */
266 |                 bug!("Forwarding pointer in tospace"),
267 |             PAIR => /* Pair */ {
268 |                 debug_assert!(size == 3)
269 |             }
270 |             RUSTDATA => /* Rustdata – not scanned by the GC */ {
271 |                 offset += size as isize - 1;
272 |                 continue;
273 |             }
274 |             VECTOR => /* Vector-like object */ { }
275 |             BYTECODE => /* Bytecode object */ {
276 |                 let ptr: *mut bytecode::BCO = current.offset(-1) as *mut _;
277 |                 relocate(bytecode::get_constants_vector(&*ptr).get(), tospace,
278 |                          fromspace);
279 |                 offset += size as isize - 1;
280 |                 continue;
281 |             }
282 |             _ => bug!("Strange header type {:x}", tag),
283 |         }
284 | 
285 |         if !(*current).leafp() {
286 |             if !(*current).raw_tag() != SYMBOL_TAG {
287 |                 for _ in 1..size {
288 |                     relocate(current.offset(offset), tospace, fromspace);
289 |                     offset += 1
290 |                 }
291 |             } else {
292 |                 relocate(current.offset(offset), tospace, fromspace);
293 |                 offset += size as isize - 1
294 |             }
295 |             offset = align_word_size(offset as usize) as isize
296 |         }
297 |     }
298 | }
299 | 
300 | /// Handles all of the data on the stack.
301 | unsafe fn scavange_stack(stack: &mut Vec<Value>,
302 |                          tospace: &mut Vec<Value>,
303 |                          fromspace: &mut Vec<Value>) {
304 |     for i in stack.iter_mut() {
305 |         relocate(i, tospace, fromspace);
306 |     }
307 | }
308 | 
309 | /// Performs a full garbage collection
310 | pub fn collect(heap: &mut Heap) {
311 |     debug!("Initiated garbage collection");
312 |     unsafe {
313 |         if cfg!(debug_assertions) {
314 |             for i in &heap.stack.innards {
315 |                 debug::assert_valid_heap_pointer(&heap.tospace, i)
316 |             }
317 |             debug::consistency_check(&heap.tospace);
318 |         }
319 |         debug!("Completed first consistency check");
320 |         mem::swap(&mut heap.tospace, &mut heap.fromspace);
321 |         heap.tospace.reserve(heap.fromspace.len() + heap.fromspace.len() / 2);
322 |         debug!("Fromspace size is {}",
323 |                heap.fromspace.len() + heap.fromspace.len() / 2);
324 |         heap.tospace.resize(0, Value::new(0));
325 |         debug!("Tospace resized to {}", heap.tospace.capacity());
326 |         debug!("Stack size is {}", heap.stack.len());
327 |         scavange_stack(&mut heap.stack, &mut heap.tospace, &mut heap.fromspace);
328 |         debug!("Stack scavanged");
329 |         scavange_heap(&mut heap.tospace, &mut heap.fromspace);
330 |         debug!("Heap scavanged");
331 |         heap.symbol_table.fixup();
332 |         debug!("Fixed up symbol table");
333 |         if cfg!(debug_assertions) {
334 |             for i in &heap.stack.innards {
335 |                 debug::assert_valid_heap_pointer(&heap.tospace, i)
336 |             }
337 |             debug::consistency_check(&heap.tospace);
338 |         }
339 |         debug!("Completed second consistency check");
340 |         heap.fromspace.resize(0, Value::new(0));
341 |         heap.last_mem_use = heap.fromspace.capacity() + 8*heap.symbol_table.contents.len()
342 |     }
343 | }
344 | 
345 | /// Represents the stack.
346 | #[derive(Debug)]
347 | pub struct Stack {
348 |     pub innards: Vec<value::Value>,
349 | }
350 | 
351 | use std::ops::{Deref, DerefMut};
352 | 
353 | /// A `Stack` acts like a `Vec`.
354 | impl Deref for Stack {
355 |     type Target = Vec<value::Value>;
356 |     fn deref(&self) -> &Vec<value::Value> {
357 |         &self.innards
358 |     }
359 | }
360 | 
361 | /// A `Stack` acts like a `Vec`.
362 | impl DerefMut for Stack {
363 |     fn deref_mut(&mut self) -> &mut Vec<value::Value> {
364 |         &mut self.innards
365 |     }
366 | }
367 | 
368 | impl Heap {
369 |     /// Allocates a Scheme pair, which must be rooted by the caller.
370 |     ///
371 |     /// The arguments are stack indexes.
372 |     pub fn alloc_pair(&mut self, car: usize, cdr: usize) {
373 |         if cfg!(debug_assertions) {
374 |             for i in &[car, cdr] {
375 |                 debug::assert_valid_heap_pointer(&self.tospace, &self.stack[*i])
376 |             }
377 |         }
378 |         // unsafe { consistency_check(&self.tospace) }
379 |         let x = SIZEOF_PAIR;
380 |         self.alloc_raw(x, value::HeaderTag::Pair);
381 |         let len = if size_of!(usize) < 8 {
382 |             self.tospace.extend_from_slice(&[self.stack[car].clone(),
383 |                                              self.stack[cdr].clone(),
384 |                                              Value::new(1)]);
385 |             self.tospace.len() - 4
386 |         } else {
387 |             self.tospace.extend_from_slice(&[self.stack[car].clone(), self.stack[cdr].clone()]);
388 |             self.tospace.len() - 3
389 |         };
390 |         let new_value = Value::new(unsafe {
391 |             self.tospace.as_ptr().offset(len as isize) as usize | value::PAIR_TAG
392 |         });
393 |         if cfg!(debug_assertions) {
394 |             debug::assert_valid_heap_pointer(&self.tospace, &new_value);
395 |         }
396 |         self.stack.push(new_value);
397 |         // unsafe { consistency_check(&self.tospace) }
398 |         // debug!("Allocated a pair")
399 |     }
400 | 
401 |     pub fn check_must_collect(&mut self) {
402 |         let should_collect = 8*self.symbol_table.contents.len() +
403 |             self.tospace.capacity() >
404 |             ((2*self.last_mem_use) + if cfg!(debug_assertions) {
405 |                 1
406 |             } else{
407 |                 1 << 16
408 |             });
409 |         if should_collect {
410 |             collect(self)
411 |         }
412 |     }
413 | 
414 |     /// FIXME use enum for tag
415 |     pub fn alloc_raw(&mut self, space: usize,
416 |                      tag: value::HeaderTag) -> (*mut libc::c_void, usize) {
417 |         debug_assert!(space > 1);
418 |         let real_space = align_word_size(space);
419 |         let tospace_space = self.tospace.capacity() - self.tospace.len();
420 |         if tospace_space < real_space  {
421 |             collect(self);
422 |         } else {
423 |             self.check_must_collect()
424 |         }
425 |         debug_assert!(((self.tospace.len()*size_of!(usize)) & 7) == 0);
426 |         let alloced_ptr = unsafe {
427 |             self.tospace.as_ptr().offset(self.tospace.len() as isize)
428 |         };
429 |         self.tospace.push(Value::new(space | tag as usize));
430 |         debug_assert!(alloced_ptr as usize & 7 == 0);
431 |         (alloced_ptr as *mut libc::c_void,
432 |          self.tospace.len() + real_space)
433 |     }
434 | 
435 |     /// Allocates a vector.  The `elements` array must be rooted for the GC.
436 |     pub fn alloc_vector(&mut self, start: usize, end: usize) {
437 |         assert!(end >= start);
438 |         let (value_ptr, final_len) = self.alloc_raw(end - start + 2,
439 |                                                     value::HeaderTag::Vector);
440 |         self.tospace.push(Value::new(0));
441 |         let ptr = value_ptr as usize | value::VECTOR_TAG;
442 |         {
443 |             let stack = &self.stack[start..end];
444 |             self.tospace.extend_from_slice(stack);
445 |         }
446 |         unsafe { self.tospace.set_len(final_len) };
447 |         self.stack.push(Value::new(ptr));
448 |     }
449 | 
450 |     /// Allocates a closure. `src` and `src2` are as found in the opcode.
451 |     pub fn alloc_closure(&mut self, src: u8, src2: u8, upvalues: usize) {
452 |         let argcount = (src as u16) << 7 | src2 as u16;
453 |         let vararg = src & ::std::i8::MIN as u8 == 0;
454 |         let stack_len = self.stack.len();
455 |         let (value_ptr, final_len) = self.alloc_raw(upvalues + 2,
456 |                                                     value::HeaderTag::Vector);
457 |         let ptr = {
458 |             let elements = &self.stack[stack_len - upvalues..stack_len];
459 |             let ptr = value_ptr as usize | value::VECTOR_TAG;
460 |             self.tospace.push(Value::new((argcount as usize) << 2 |
461 |                                          (-(vararg as isize) as usize &
462 |                                           ::std::isize::MIN as usize)));
463 |             self.tospace.extend_from_slice(elements);
464 |             unsafe { self.tospace.set_len(final_len) };
465 |             ptr
466 |         };
467 |         self.stack.push(Value::new(ptr));
468 |     }
469 | 
470 |     /// Create an instance of the garage collector
471 |     pub fn new(size: usize) -> Self {
472 |         Heap {
473 |             fromspace: Vec::with_capacity(size),
474 |             tospace: Vec::with_capacity(size),
475 |             symbol_table: symbol::SymbolTable::default(),
476 |             environment: ptr::null_mut(),
477 |             constants: ptr::null(),
478 |             stack: Stack { innards: Vec::with_capacity(1 << 16) },
479 |             last_mem_use: 1<<16
480 |         }
481 |     }
482 | 
483 |     /// Interns a symbol.
484 |     pub fn intern(&mut self, string: &str) {
485 |         use symbol::Symbol;
486 |         use std::rc::Rc;
487 |         {
488 |             let rc = Rc::new(string.to_owned());
489 |             let val = self.symbol_table.contents
490 |                                        .entry(rc.clone())
491 |                                        .or_insert_with(|| Box::new(Symbol::new(rc)));
492 |             self.stack.push(Value::new(&mut(**val) as *mut _ as usize |
493 |                                        value::SYMBOL_TAG))
494 |         }
495 |         self.check_must_collect()
496 |     }
497 | 
498 | 
499 |     pub fn store_global(&mut self) -> Result<(), String> {
500 |         match self.stack.pop().unwrap().kind() {
501 |             Kind::Symbol(ptr) => {
502 |                 let val = self.stack.pop().unwrap();
503 |                 unsafe {
504 |                     Ok(*(*ptr).contents.get() = val)
505 |                 }
506 |             }
507 |             _ => Err("Attempt to get the value of a non-symbol".to_owned()),
508 |         }
509 |     }
510 | 
511 |     pub fn load_global(&mut self) -> Result<(), String> {
512 |         match self.stack.pop().map(|x| x.kind()) {
513 |             Some(Kind::Symbol(ptr)) => {
514 |                 let contents = unsafe { &*(*ptr).contents.get() };
515 |                 Ok(self.stack.push(contents.clone()))
516 |             }
517 |             _ => Err("Attempt to get the value of a non-symbol".to_owned()),
518 |         }
519 |     }
520 | }
521 | 
522 | #[cfg(test)]
523 | mod tests {
524 |     use super::*;
525 |     use value::*;
526 |     use std::cell::Cell;
527 |     #[test]
528 |     fn can_allocate_objects() {
529 |         let zero: Value = Value { contents: Cell::new(0) };
530 |         let mut heap = Heap::new(1 << 4);
531 |         super::collect(&mut heap);
532 |         debug!("HEADER_TAG = {:x}, PAIR_TAG = {:x}, SIZEOF_PAIR = {:x}",
533 |                HEADER_TAG,
534 |                PAIR_HEADER,
535 |                SIZEOF_PAIR);
536 |         heap.stack.push(zero);
537 |         heap.alloc_pair(0, 0);
538 |         heap.stack[0] = heap.stack.pop().unwrap();
539 |         // debug!("{:?}", heap);
540 |         for i in 1..((1 << 11)) {
541 |             heap.alloc_pair(0, 0);
542 |             assert_eq!(heap.stack.len(), 2);
543 |             assert_eq!(heap.stack[1].tag(), Tags::Pair);
544 |             heap.stack[0] = heap.stack.pop().unwrap();
545 |             let assert_valid = |heap: &Heap| {
546 |                 let ref new_pair = heap.stack[0];
547 |                 assert_eq!(heap.stack[0].tag(), Tags::Pair);
548 |                 assert_eq!(new_pair.size(), Some(3));
549 |                 if let Kind::Pair(ptr) = new_pair.kind() {
550 |                     assert_eq!(unsafe { (*ptr).car.tag() }, Tags::Pair);
551 |                     assert_eq!(unsafe { (*ptr).cdr.tag() }, Tags::Pair)
552 |                 } else {
553 |                     unreachable!()
554 |                 }
555 |             };
556 |             assert_valid(&heap);
557 |             // super::collect(&mut heap);
558 |             assert_valid(&heap);
559 |             assert!(heap.tospace.len() >= 3 * i)
560 |     }
561 |     heap.stack.pop();
562 |     assert!(heap.stack.len() == 0);
563 |     // assert!(heap.fromspace.capacity() > 3* (1 << 20));
564 |     // debug!("{:?}", heap);
565 |     super::collect(&mut heap);
566 |     assert!(heap.tospace.len() == 0)
567 | }
568 | }
569 | 


--------------------------------------------------------------------------------
/lib/system.lsp:
--------------------------------------------------------------------------------
   1 | ; -*- scheme -*-
   2 | ; femtoLisp standard library
   3 | ; by Jeff Bezanson (C) 2009
   4 | ; Distributed under the BSD License
   5 | 
   6 | (define (void) #t)  ; the unspecified value
   7 | 
   8 | (define *builtins*
   9 |   (vector
  10 |    0 0 0 0 0 0 0 0 0 0 0 0
  11 |    (lambda (x y) (eq? x y))          (lambda (x y) (eqv? x y))
  12 |    (lambda (x y) (equal? x y))       (lambda (x) (atom? x))
  13 |    (lambda (x) (not x))              (lambda (x) (null? x))
  14 |    (lambda (x) (boolean? x))         (lambda (x) (symbol? x))
  15 |    (lambda (x) (number? x))          (lambda (x) (bound? x))
  16 |    (lambda (x) (pair? x))            (lambda (x) (builtin? x))
  17 |    (lambda (x) (vector? x))          (lambda (x) (fixnum? x))
  18 |    (lambda (x) (function? x))        (lambda (x y) (cons x y))
  19 |    (lambda rest rest)                (lambda (x) (car x))
  20 |    (lambda (x) (cdr x))              (lambda (x y) (set-car! x y))
  21 |    (lambda (x y) (set-cdr! x y))     (lambda rest (apply apply rest))
  22 |    (lambda rest (apply + rest))      (lambda rest (apply - rest))
  23 |    (lambda rest (apply * rest))      (lambda rest (apply / rest))
  24 |    (lambda rest (apply div0 rest))   (lambda (x y) (= x y))
  25 |    (lambda (x y) (< x y))            (lambda (x y) (compare x y))
  26 |    (lambda rest (apply vector rest)) (lambda (x y) (aref x y))
  27 |    (lambda (x y z) (aset! x y z))))
  28 | 
  29 | (if (not (bound? '*syntax-environment*))
  30 |     (define *syntax-environment* (table)))
  31 | 
  32 | #;(define (set-syntax! s v) (put! *syntax-environment* s v))
  33 | #;(define (symbol-syntax s) (get *syntax-environment* s #f))
  34 | 
  35 | #;(define-macro (define-macro form . body)
  36 |   `(set-syntax! ',(car form)
  37 | 		(lambda ,(cdr form) ,@body)))
  38 | 
  39 | (define (map1 f lst acc)
  40 |   (cdr
  41 |    (prog1 acc
  42 | 	  (while (pair? lst)
  43 | 		 (begin (set! acc
  44 | 			      (cdr (set-cdr! acc (cons (f (car lst)) ()))))
  45 | 			(set! lst (cdr lst)))))))
  46 | 
  47 | (define (mapn f lsts)
  48 |   (if (null? (car lsts))
  49 |       ()
  50 |       (cons (apply f (map1 car lsts (list ())))
  51 | 	    (mapn  f (map1 cdr lsts (list ()))))))
  52 | 
  53 | (define (map f lst . lsts)
  54 |   (if (null? lsts)
  55 |       (map1 f lst (list ()))
  56 |       (mapn f (cons lst lsts))))
  57 | 
  58 | (define-macro (cond . clauses)
  59 |   (define (cond-clauses->if lst)
  60 |     (if (atom? lst)
  61 | 	#f
  62 | 	(let ((clause (car lst)))
  63 | 	  (if (or (eq? (car clause) 'else)
  64 | 		  (eq? (car clause) #t))
  65 | 	      (if (null? (cdr clause))
  66 | 		  (car clause)
  67 | 		  (cons 'begin (cdr clause)))
  68 | 	      (if (null? (cdr clause))
  69 | 		  ; test by itself
  70 | 		  (list 'or
  71 | 			(car clause)
  72 | 			(cond-clauses->if (cdr lst)))
  73 | 		  ; test => expression
  74 | 		  (if (eq? (cadr clause) '=>)
  75 | 		      (if (1arg-lambda? (caddr clause))
  76 | 			  ; test => (lambda (x) ...)
  77 | 			  (let ((var (caadr (caddr clause))))
  78 | 			    `(let ((,var ,(car clause)))
  79 | 			       (if ,var ,(cons 'begin (cddr (caddr clause)))
  80 | 				   ,(cond-clauses->if (cdr lst)))))
  81 | 			  ; test => proc
  82 | 			  (let ((b (gensym)))
  83 | 			    `(let ((,b ,(car clause)))
  84 | 			       (if ,b
  85 | 				   (,(caddr clause) ,b)
  86 | 				   ,(cond-clauses->if (cdr lst))))))
  87 | 		      (list 'if
  88 | 			    (car clause)
  89 | 			    (cons 'begin (cdr clause))
  90 | 			    (cond-clauses->if (cdr lst)))))))))
  91 |   (cond-clauses->if clauses))
  92 | 
  93 | ; standard procedures ---------------------------------------------------------
  94 | 
  95 | (define (member item lst)
  96 |   (cond ((atom? lst) #f)
  97 |         ((equal?     (car lst) item) lst)
  98 |         (#t          (member item (cdr lst)))))
  99 | (define (memv item lst)
 100 |   (cond ((atom? lst) #f)
 101 |         ((eqv?       (car lst) item) lst)
 102 |         (#t          (memv item (cdr lst)))))
 103 | 
 104 | (define (assoc item lst)
 105 |   (cond ((atom? lst) #f)
 106 | 	((equal?     (caar lst) item) (car lst))
 107 | 	(#t          (assoc item (cdr lst)))))
 108 | (define (assv item lst)
 109 |   (cond ((atom? lst) #f)
 110 | 	((eqv?       (caar lst) item) (car lst))
 111 | 	(#t          (assv item (cdr lst)))))
 112 | 
 113 | (define (>  a b) (< b a))
 114 | (define (<= a b) (or (< a b) (= a b)))
 115 | (define (>= a b) (or (< b a) (= a b)))
 116 | (define (negative? x) (< x 0))
 117 | (define (zero? x)     (= x 0))
 118 | (define (positive? x) (> x 0))
 119 | (define (even? x) (= (logand x 1) 0))
 120 | (define (odd? x) (not (even? x)))
 121 | (define (identity x) x)
 122 | (define (1+ n) (+ n 1))
 123 | (define (1- n) (- n 1))
 124 | (define (mod0 x y) (- x (* (div0 x y) y)))
 125 | (define (div x y) (+ (div0 x y)
 126 | 		     (or (and (< x 0)
 127 | 			      (or (and (< y 0) 1)
 128 | 				  -1))
 129 | 			 0)))
 130 | (define (mod x y) (- x (* (div x y) y)))
 131 | (define (random n)
 132 |   (if (integer? n)
 133 |       (mod (rand) n)
 134 |       (* (rand.double) n)))
 135 | (define (abs x)   (if (< x 0) (- x) x))
 136 | (define (max x0 . xs)
 137 |   (if (null? xs) x0
 138 |       (foldl (lambda (a b) (if (< a b) b a)) x0 xs)))
 139 | (define (min x0 . xs)
 140 |   (if (null? xs) x0
 141 |       (foldl (lambda (a b) (if (< a b) a b)) x0 xs)))
 142 | (define (char? x) (eq? (typeof x) 'wchar))
 143 | (define (array? x) (or (vector? x)
 144 | 		       (let ((t (typeof x)))
 145 | 			 (and (pair? t) (eq? (car t) 'array)))))
 146 | (define (closure? x) (and (function? x) (not (builtin? x))))
 147 | 
 148 | (define (caar x) (car (car x)))
 149 | (define (cadr x) (car (cdr x)))
 150 | (define (cdar x) (cdr (car x)))
 151 | (define (cddr x) (cdr (cdr x)))
 152 | (define (caaar x) (car (car (car x))))
 153 | (define (caadr x) (car (car (cdr x))))
 154 | (define (cadar x) (car (cdr (car x))))
 155 | (define (caddr x) (car (cdr (cdr x))))
 156 | (define (cdaar x) (cdr (car (car x))))
 157 | (define (cdadr x) (cdr (car (cdr x))))
 158 | (define (cddar x) (cdr (cdr (car x))))
 159 | (define (cdddr x) (cdr (cdr (cdr x))))
 160 | (define (caaaar x) (car (car (car (car x)))))
 161 | (define (caaadr x) (car (car (car (cdr x)))))
 162 | (define (caadar x) (car (car (cdr (car x)))))
 163 | (define (caaddr x) (car (car (cdr (cdr x)))))
 164 | (define (cadaar x) (car (cdr (car (car x)))))
 165 | (define (cadadr x) (car (cdr (car (cdr x)))))
 166 | (define (caddar x) (car (cdr (cdr (car x)))))
 167 | (define (cadddr x) (car (cdr (cdr (cdr x)))))
 168 | (define (cdaaar x) (cdr (car (car (car x)))))
 169 | (define (cdaadr x) (cdr (car (car (cdr x)))))
 170 | (define (cdadar x) (cdr (car (cdr (car x)))))
 171 | (define (cdaddr x) (cdr (car (cdr (cdr x)))))
 172 | (define (cddaar x) (cdr (cdr (car (car x)))))
 173 | (define (cddadr x) (cdr (cdr (car (cdr x)))))
 174 | (define (cdddar x) (cdr (cdr (cdr (car x)))))
 175 | (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
 176 | 
 177 | (let ((*values* (list '*values*)))
 178 |   (set! values
 179 | 	(lambda vs
 180 | 	  (if (and (pair? vs) (null? (cdr vs)))
 181 | 	      (car vs)
 182 | 	      (cons *values* vs))))
 183 |   (set! call-with-values
 184 | 	(lambda (producer consumer)
 185 | 	  (let ((res (producer)))
 186 | 	    (if (and (pair? res) (eq? *values* (car res)))
 187 | 		(apply consumer (cdr res))
 188 | 		(consumer res))))))
 189 | 
 190 | ; list utilities --------------------------------------------------------------
 191 | 
 192 | (define (every pred lst)
 193 |   (or (atom? lst)
 194 |       (and (pred (car lst))
 195 |            (every pred (cdr lst)))))
 196 | 
 197 | (define (any pred lst)
 198 |   (and (pair? lst)
 199 |        (or (pred (car lst))
 200 |            (any pred (cdr lst)))))
 201 | 
 202 | (define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
 203 | 
 204 | (define (list-tail lst n)
 205 |   (if (<= n 0) lst
 206 |       (list-tail (cdr lst) (- n 1))))
 207 | 
 208 | (define (list-head lst n)
 209 |   (if (<= n 0) ()
 210 |       (cons (car lst)
 211 | 	    (list-head (cdr lst) (- n 1)))))
 212 | 
 213 | (define (list-ref lst n)
 214 |   (car (list-tail lst n)))
 215 | 
 216 | ; bounded length test
 217 | ; use this instead of (= (length lst) n), since it avoids unnecessary
 218 | ; work and always terminates.
 219 | (define (length= lst n)
 220 |   (cond ((< n 0)     #f)
 221 | 	((= n 0)     (atom? lst))
 222 | 	((atom? lst) (= n 0))
 223 | 	(else        (length= (cdr lst) (- n 1)))))
 224 | 
 225 | (define (length> lst n)
 226 |   (cond ((< n 0)     lst)
 227 | 	((= n 0)     (and (pair? lst) lst))
 228 | 	((atom? lst) (< n 0))
 229 | 	(else        (length> (cdr lst) (- n 1)))))
 230 | 
 231 | (define (last-pair l)
 232 |   (if (atom? (cdr l))
 233 |       l
 234 |       (last-pair (cdr l))))
 235 | 
 236 | (define (lastcdr l)
 237 |   (if (atom? l)
 238 |       l
 239 |       (cdr (last-pair l))))
 240 | 
 241 | (define (to-proper l)
 242 |   (cond ((null? l) l)
 243 | 	((atom? l) (list l))
 244 | 	(else (cons (car l) (to-proper (cdr l))))))
 245 | 
 246 | (define (map! f lst)
 247 |   (prog1 lst
 248 | 	 (while (pair? lst)
 249 | 		(set-car! lst (f (car lst)))
 250 | 		(set! lst (cdr lst)))))
 251 | 
 252 | (define (filter pred lst)
 253 |   (define (filter- f lst acc)
 254 |     (cdr
 255 |      (prog1 acc
 256 |       (while (pair? lst)
 257 | 	     (begin (if (pred (car lst))
 258 | 			(set! acc
 259 | 			      (cdr (set-cdr! acc (cons (car lst) ())))))
 260 | 		    (set! lst (cdr lst)))))))
 261 |   (filter- pred lst (list ())))
 262 | 
 263 | (define (separate pred lst)
 264 |   (define (separate- pred lst yes no)
 265 |     (let ((vals
 266 | 	   (prog1
 267 | 	    (cons yes no)
 268 | 	    (while (pair? lst)
 269 | 		   (begin (if (pred (car lst))
 270 | 			      (set! yes
 271 | 				    (cdr (set-cdr! yes (cons (car lst) ()))))
 272 | 			      (set! no
 273 | 				    (cdr (set-cdr! no  (cons (car lst) ())))))
 274 | 			  (set! lst (cdr lst)))))))
 275 |       (values (cdr (car vals)) (cdr (cdr vals)))))
 276 |   (separate- pred lst (list ()) (list ())))
 277 | 
 278 | (define (count f l)
 279 |   (define (count- f l n)
 280 |     (if (null? l)
 281 | 	n
 282 | 	(count- f (cdr l) (if (f (car l))
 283 | 			      (+ n 1)
 284 | 			      n))))
 285 |   (count- f l 0))
 286 | 
 287 | (define (nestlist f zero n)
 288 |   (if (<= n 0) ()
 289 |       (cons zero (nestlist f (f zero) (- n 1)))))
 290 | 
 291 | (define (foldr f zero lst)
 292 |   (if (null? lst) zero
 293 |       (f (car lst) (foldr f zero (cdr lst)))))
 294 | 
 295 | (define (foldl f zero lst)
 296 |   (if (null? lst) zero
 297 |       (foldl f (f (car lst) zero) (cdr lst))))
 298 | 
 299 | (define (reverse- zero lst)
 300 |   (if (null? lst) zero
 301 |       (reverse- (cons (car lst) zero) (cdr lst))))
 302 | 
 303 | (define (reverse lst) (reverse- () lst))
 304 | 
 305 | (define (reverse!- prev l)
 306 |   (while (pair? l)
 307 | 	 (set! l (prog1 (cdr l)
 308 | 			(set-cdr! l (prog1 prev
 309 | 					   (set! prev l))))))
 310 |   prev)
 311 | 
 312 | (define (reverse! l) (reverse!- () l))
 313 | 
 314 | (define (copy-tree l)
 315 |   (if (atom? l) l
 316 |     (cons (copy-tree (car l))
 317 |           (copy-tree (cdr l)))))
 318 | 
 319 | (define (delete-duplicates lst)
 320 |   (if (length> lst 20)
 321 |       (let ((t (table)))
 322 | 	(let loop ((l lst) (acc '()))
 323 | 	  (if (atom? l)
 324 | 	      (reverse! acc)
 325 | 	      (if (has? t (car l))
 326 | 		  (loop (cdr l) acc)
 327 | 		  (begin
 328 | 		    (put! t (car l) #t)
 329 | 		    (loop (cdr l) (cons (car l) acc)))))))
 330 |       (if (atom? lst)
 331 | 	  lst
 332 | 	  (let ((elt  (car lst))
 333 | 		(tail (cdr lst)))
 334 | 	    (if (member elt tail)
 335 | 		(delete-duplicates tail)
 336 | 		(cons elt
 337 | 		      (delete-duplicates tail)))))))
 338 | 
 339 | ; backquote -------------------------------------------------------------------
 340 | 
 341 | (define (revappend l1 l2) (reverse-  l2 l1))
 342 | (define (nreconc   l1 l2) (reverse!- l2 l1))
 343 | 
 344 | (define (self-evaluating? x)
 345 |   (or (and (atom? x)
 346 |            (not (symbol? x)))
 347 |       (and (constant? x)
 348 | 	   (symbol? x)
 349 |            (eq x (top-level-value x)))))
 350 | 
 351 | (define-macro (quasiquote x) (bq-process x 0))
 352 | 
 353 | (define (splice-form? x)
 354 |   (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
 355 | 			 (eq? (car x) 'unquote-nsplicing)
 356 | 			 (and (eq? (car x) 'unquote)
 357 | 			      (length> x 2))))
 358 |       (eq? x 'unquote)))
 359 | 
 360 | ;; bracket without splicing
 361 | (define (bq-bracket1 x d)
 362 |   (if (and (pair? x) (eq? (car x) 'unquote))
 363 |       (if (= d 0)
 364 | 	  (cadr x)
 365 | 	  (list cons ''unquote
 366 | 		(bq-process (cdr x) (- d 1))))
 367 |       (bq-process x d)))
 368 | 
 369 | (define (bq-bracket x d)
 370 |   (cond ((atom? x)  (list list (bq-process x d)))
 371 | 	((eq? (car x) 'unquote)
 372 | 	 (if (= d 0)
 373 | 	     (cons list (cdr x))
 374 | 	     (list list (list cons ''unquote
 375 | 			      (bq-process (cdr x) (- d 1))))))
 376 | 	((eq? (car x) 'unquote-splicing)
 377 | 	 (if (= d 0)
 378 | 	     (list 'copy-list (cadr x))
 379 | 	     (list list (list list ''unquote-splicing
 380 | 			      (bq-process (cadr x) (- d 1))))))
 381 | 	((eq? (car x) 'unquote-nsplicing)
 382 | 	 (if (= d 0)
 383 | 	     (cadr x)
 384 | 	     (list list (list list ''unquote-nsplicing
 385 | 			      (bq-process (cadr x) (- d 1))))))
 386 | 	(else  (list list (bq-process x d)))))
 387 | 
 388 | (define (bq-process x d)
 389 |   (cond ((symbol? x)  (list 'quote x))
 390 | 	((vector? x)
 391 | 	 (let ((body (bq-process (vector->list x) d)))
 392 | 	   (if (eq? (car body) list)
 393 | 	       (cons vector (cdr body))
 394 | 	       (list apply vector body))))
 395 |         ((atom? x)  x)
 396 |         ((eq? (car x) 'quasiquote)
 397 | 	 (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
 398 |         ((eq? (car x) 'unquote)
 399 | 	 (if (and (= d 0) (length= x 2))
 400 | 	     (cadr x)
 401 | 	     (list cons ''unquote (bq-process (cdr x) (- d 1)))))
 402 | 	((not (any splice-form? x))
 403 |          (let ((lc    (lastcdr x))
 404 |                (forms (map (lambda (x) (bq-bracket1 x d)) x)))
 405 |            (if (null? lc)
 406 |                (cons list forms)
 407 | 	       (if (null? (cdr forms))
 408 | 		   (list cons (car forms) (bq-process lc d))
 409 | 		   (nconc (cons list* forms) (list (bq-process lc d)))))))
 410 | 	(else
 411 | 	 (let loop ((p x) (q ()))
 412 | 	   (cond ((null? p) ;; proper list
 413 | 		  (cons 'nconc (reverse! q)))
 414 | 		 ((pair? p)
 415 | 		  (cond ((eq? (car p) 'unquote)
 416 | 			 ;; (... . ,x)
 417 | 			 (cons 'nconc
 418 | 			       (nreconc q
 419 | 					(if (= d 0)
 420 | 					    (cdr p)
 421 | 					    (list (list list ''unquote)
 422 | 						  (bq-process (cdr p)
 423 | 							       (- d 1)))))))
 424 | 			(else
 425 | 			 (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
 426 | 		 (else
 427 | 		  ;; (... . x)
 428 | 		  (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
 429 | 
 430 | ; standard macros -------------------------------------------------------------
 431 | 
 432 | (define (quote-value v)
 433 |   (if (self-evaluating? v)
 434 |       v
 435 |       (list 'quote v)))
 436 | 
 437 | (define-macro (let* binds . body)
 438 |   (if (atom? binds) `((lambda () ,@body))
 439 |       `((lambda (,(caar binds))
 440 | 	  ,@(if (pair? (cdr binds))
 441 | 		`((let* ,(cdr binds) ,@body))
 442 | 		body))
 443 | 	,(cadar binds))))
 444 | 
 445 | (define-macro (when   c . body) (list 'if c (cons 'begin body) #f))
 446 | (define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
 447 | 
 448 | (define-macro (case key . clauses)
 449 |   (define (vals->cond key v)
 450 |     (cond ((eq? v 'else)   'else)
 451 | 	  ((null? v)       #f)
 452 | 	  ((symbol? v)     `(eq?  ,key ,(quote-value v)))
 453 |           ((atom? v)       `(eqv? ,key ,(quote-value v)))
 454 | 	  ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
 455 | 	  ((every symbol? v)
 456 | 	                   `(memq ,key ',v))
 457 | 	  (else            `(memv ,key ',v))))
 458 |   (let ((g (gensym)))
 459 |     `(let ((,g ,key))
 460 |        (cond ,@(map (lambda (clause)
 461 | 		      (cons (vals->cond g (car clause))
 462 | 			    (cdr clause)))
 463 | 		    clauses)))))
 464 | 
 465 | (define-macro (do vars test-spec . commands)
 466 |   (let ((loop (gensym))
 467 | 	(test-expr (car test-spec))
 468 | 	(vars  (map car  vars))
 469 | 	(inits (map cadr vars))
 470 | 	(steps (map (lambda (x)
 471 | 		      (if (pair? (cddr x))
 472 | 			  (caddr x)
 473 | 			  (car x)))
 474 | 		    vars)))
 475 |     `(letrec ((,loop (lambda ,vars
 476 | 		       (if ,test-expr
 477 | 			   (begin
 478 | 			     ,@(cdr test-spec))
 479 | 			   (begin
 480 | 			     ,@commands
 481 | 			     (,loop ,@steps))))))
 482 |        (,loop ,@inits))))
 483 | 
 484 | ; SRFI 8
 485 | (define-macro (receive formals expr . body)
 486 |   `(call-with-values (lambda () ,expr)
 487 |      (lambda ,formals ,@body)))
 488 | 
 489 | (define-macro (dotimes var . body)
 490 |   (let ((v (car var))
 491 |         (cnt (cadr var)))
 492 |     `(for 0 (- ,cnt 1)
 493 |           (lambda (,v) ,@body))))
 494 | 
 495 | (define (map-int f n)
 496 |   (if (<= n 0)
 497 |       ()
 498 |     (let ((first (cons (f 0) ()))
 499 |           (acc ()))
 500 |       (set! acc first)
 501 |       (for 1 (- n 1)
 502 |            (lambda (i)
 503 |              (begin (set-cdr! acc (cons (f i) ()))
 504 |                     (set! acc (cdr acc)))))
 505 |       first)))
 506 | 
 507 | (define (iota n) (map-int identity n))
 508 | 
 509 | (define (for-each f l . lsts)
 510 |   (define (for-each-n f lsts)
 511 |     (if (pair? (car lsts))
 512 | 	(begin (apply f (map car lsts))
 513 | 	       (for-each-n f (map cdr lsts)))))
 514 |   (if (null? lsts)
 515 |       (while (pair? l)
 516 | 	     (begin (f (car l))
 517 | 		    (set! l (cdr l))))
 518 |       (for-each-n f (cons l lsts)))
 519 |   #t)
 520 | 
 521 | (define-macro (with-bindings binds . body)
 522 |   (let ((vars (map car binds))
 523 | 	(vals (map cadr binds))
 524 | 	(olds (map (lambda (x) (gensym)) binds)))
 525 |     `(let ,(map list olds vars)
 526 |        ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
 527 |        (unwind-protect
 528 | 	(begin ,@body)
 529 | 	(begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
 530 | 
 531 | ; exceptions ------------------------------------------------------------------
 532 | 
 533 | (define (error . args) (raise (cons 'error args)))
 534 | 
 535 | (define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
 536 | (define-macro (catch tag expr)
 537 |   (let ((e (gensym)))
 538 |     `(trycatch ,expr
 539 |                (lambda (,e) (if (and (pair? ,e)
 540 |                                      (eq (car  ,e) 'thrown-value)
 541 |                                      (eq (cadr ,e) ,tag))
 542 |                                 (caddr ,e)
 543 | 				(raise ,e))))))
 544 | 
 545 | (define-macro (unwind-protect expr finally)
 546 |   (let ((e   (gensym))
 547 | 	(thk (gensym)))
 548 |     `(let ((,thk (lambda () ,finally)))
 549 |        (prog1 (trycatch ,expr
 550 | 			(lambda (,e) (begin (,thk) (raise ,e))))
 551 | 	      (,thk)))))
 552 | 
 553 | ; debugging utilities ---------------------------------------------------------
 554 | 
 555 | (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
 556 | #;(begin
 557 | (define traced?
 558 |   (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args))
 559 | 						     (newline)
 560 | 						     (apply apply args)))))
 561 |     (lambda (f)
 562 |       (and (closure? f)
 563 | 	   (equal? (function:code f)
 564 | 		   (function:code sample-traced-lambda))))))
 565 | 
 566 | (define (trace sym)
 567 |   (let* ((func (top-level-value sym))
 568 | 	 (args (gensym)))
 569 |     (if (not (traced? func))
 570 | 	(set-top-level-value! sym
 571 | 			      (eval
 572 | 			       `(lambda ,args
 573 | 				  (begin (write (cons ',sym ,args))
 574 | 					 (newline)
 575 | 					 (apply ',func ,args)))))))
 576 |   'ok)
 577 | 
 578 | (define (untrace sym)
 579 |   (let ((func (top-level-value sym)))
 580 |     (if (traced? func)
 581 | 	(set-top-level-value! sym
 582 | 			      (aref (function:vals func) 2)))))
 583 | 
 584 | (define-macro (time expr)
 585 |   (let ((t0 (gensym)))
 586 |     `(let ((,t0 (time.now)))
 587 |        (prog1
 588 | 	,expr
 589 | 	(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
 590 | 
 591 | ; text I/O --------------------------------------------------------------------
 592 | 
 593 | (define (print . args) (for-each write args))
 594 | (define (princ . args)
 595 |   (with-bindings ((*print-readably* #f))
 596 | 		 (for-each write args)))
 597 | 
 598 | (define (newline (port *output-stream*))
 599 |   (io.write port *linefeed*)
 600 |   #t)
 601 | 
 602 | (define (io.readline s) (io.readuntil s #\linefeed))
 603 | 
 604 | ; call f on a stream until the stream runs out of data
 605 | (define (read-all-of f s)
 606 |   (let loop ((lines ())
 607 | 	     (curr  (f s)))
 608 |     (if (io.eof? s)
 609 | 	(reverse! lines)
 610 | 	(loop (cons curr lines) (f s)))))
 611 | 
 612 | (define (io.readlines s) (read-all-of io.readline s))
 613 | (define (read-all s) (read-all-of read s))
 614 | 
 615 | (define (io.readall s)
 616 |   (let ((b (buffer)))
 617 |     (io.copy b s)
 618 |     (let ((str (io.tostring! b)))
 619 |       (if (and (equal? str "") (io.eof? s))
 620 | 	  (eof-object)
 621 | 	  str))))
 622 | 
 623 | (define-macro (with-output-to stream . body)
 624 |   `(with-bindings ((*output-stream* ,stream))
 625 | 		  ,@body))
 626 | (define-macro (with-input-from stream . body)
 627 |   `(with-bindings ((*input-stream* ,stream))
 628 | 		  ,@body))
 629 | 
 630 | ; vector functions ------------------------------------------------------------
 631 | 
 632 | (define (list->vector l) (apply vector l))
 633 | (define (vector->list v)
 634 |   (let ((n (length v))
 635 |         (l ()))
 636 |     (for 1 n
 637 |          (lambda (i)
 638 |            (set! l (cons (aref v (- n i)) l))))
 639 |     l))
 640 | 
 641 | (define (vector.map f v)
 642 |   (let* ((n (length v))
 643 |          (nv (vector.alloc n)))
 644 |     (for 0 (- n 1)
 645 |          (lambda (i)
 646 |            (aset! nv i (f (aref v i)))))
 647 |     nv))
 648 | 
 649 | ; table functions -------------------------------------------------------------
 650 | 
 651 | (define (table.pairs t)
 652 |   (table.foldl (lambda (k v z) (cons (cons k v) z))
 653 |                () t))
 654 | (define (table.keys t)
 655 |   (table.foldl (lambda (k v z) (cons k z))
 656 |                () t))
 657 | (define (table.values t)
 658 |   (table.foldl (lambda (k v z) (cons v z))
 659 |                () t))
 660 | (define (table.clone t)
 661 |   (let ((nt (table)))
 662 |     (table.foldl (lambda (k v z) (put! nt k v))
 663 |                  () t)
 664 |     nt))
 665 | (define (table.invert t)
 666 |   (let ((nt (table)))
 667 |     (table.foldl (lambda (k v z) (put! nt v k))
 668 | 		 () t)
 669 |     nt))
 670 | (define (table.foreach f t)
 671 |   (table.foldl (lambda (k v z) (begin (f k v) #t)) () t))
 672 | 
 673 | ; string functions ------------------------------------------------------------
 674 | 
 675 | (define (string.tail s n) (string.sub s (string.inc s 0 n)))
 676 | 
 677 | ;;(define *whitespace*
 678 | ;;  (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
 679 | ;;			      8193 8194 8195 8196 8197 8198 8199 8200
 680 | ;;			      8201 8202 8232 8233 8239 8287 12288)))
 681 | 
 682 | (define (string.trim s at-start at-end)
 683 |   (define (trim-start s chars i L)
 684 |     (if (and (< i L)
 685 | 	     (string.find chars (string.char s i)))
 686 | 	(trim-start s chars (string.inc s i) L)
 687 | 	i))
 688 |   (define (trim-end s chars i)
 689 |     (if (and (> i 0)
 690 | 	     (string.find chars (string.char s (string.dec s i))))
 691 | 	(trim-end s chars (string.dec s i))
 692 | 	i))
 693 |   (let ((L (length s)))
 694 |     (string.sub s
 695 | 		(trim-start s at-start 0 L)
 696 | 		(trim-end   s at-end   L))))
 697 | 
 698 | (define (string.map f s)
 699 |   (let ((b (buffer))
 700 | 	(n (length s)))
 701 |     (let ((i 0))
 702 |       (while (< i n)
 703 | 	     (begin (io.putc b (f (string.char s i)))
 704 | 		    (set! i (string.inc s i)))))
 705 |     (io.tostring! b)))
 706 | 
 707 | (define (string.rep s k)
 708 |   (cond ((< k 4)
 709 | 	 (cond ((<= k 0) "")
 710 | 	       ((=  k 1) (string s))
 711 | 	       ((=  k 2) (string s s))
 712 | 	       (else     (string s s s))))
 713 | 	((odd? k) (string s (string.rep s (- k 1))))
 714 | 	(else     (string.rep (string s s) (/ k 2)))))
 715 | 
 716 | (define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s))
 717 | (define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))
 718 | 
 719 | (define (print-to-string v)
 720 |   (let ((b (buffer)))
 721 |     (write v b)
 722 |     (io.tostring! b)))
 723 | 
 724 | (define (string.join strlist sep)
 725 |   (if (null? strlist) ""
 726 |       (let ((b (buffer)))
 727 | 	(io.write b (car strlist))
 728 | 	(for-each (lambda (s) (begin (io.write b sep)
 729 | 				     (io.write b s)))
 730 | 		  (cdr strlist))
 731 | 	(io.tostring! b))))
 732 | 
 733 | ; toplevel --------------------------------------------------------------------
 734 | 
 735 | (define (macrocall? e) (and (symbol? (car e))
 736 | 			    (symbol-syntax (car e))))
 737 | 
 738 | (define (macroexpand-1 e)
 739 |   (if (atom? e) e
 740 |       (let ((f (macrocall? e)))
 741 | 	(if f (apply f (cdr e))
 742 | 	    e))))
 743 | 
 744 | (define (expand e)
 745 |   ; symbol resolves to toplevel; i.e. has no shadowing definition
 746 |   (define (top? s env) (not (or (bound? s) (assq s env))))
 747 |   
 748 |   (define (splice-begin body)
 749 |     (cond ((atom? body) body)
 750 | 	  ((equal? body '((begin)))
 751 | 	   body)
 752 | 	  ((and (pair? (car body))
 753 | 		(eq? (caar body) 'begin))
 754 | 	   (append (splice-begin (cdar body)) (splice-begin (cdr body))))
 755 | 	  (else
 756 | 	   (cons (car body) (splice-begin (cdr body))))))
 757 |   
 758 |   (define *expanded* (list '*expanded*))
 759 |   
 760 |   (define (expand-body body env)
 761 |     (if (atom? body) body
 762 | 	(let* ((body  (if (top? 'begin env)
 763 | 			  (splice-begin body)
 764 | 			  body))
 765 | 	       (def?  (top? 'define env))
 766 | 	       (dvars (if def? (get-defined-vars body) ()))
 767 | 	       (env   (nconc (map list dvars) env)))
 768 | 	  (if (not def?)
 769 | 	      (map (lambda (x) (expand-in x env)) body)
 770 | 	      (let* ((ex-nondefs    ; expand non-definitions
 771 | 		      (let loop ((body body))
 772 | 			(cond ((atom? body) body)
 773 | 			      ((and (pair? (car body))
 774 | 				    (eq? 'define (caar body)))
 775 | 			       (cons (car body) (loop (cdr body))))
 776 | 			      (else
 777 | 			       (let ((form (expand-in (car body) env)))
 778 | 				 (set! env (nconc
 779 | 					    (map list (get-defined-vars form))
 780 | 					    env))
 781 | 				 (cons
 782 | 				  (cons *expanded* form)
 783 | 				  (loop (cdr body))))))))
 784 | 		     (body ex-nondefs))
 785 | 		(while (pair? body) ; now expand deferred definitions
 786 | 		       (if (not (eq? *expanded* (caar body)))
 787 | 			   (set-car! body (expand-in (car body) env))
 788 | 			   (set-car! body (cdar body)))
 789 | 		       (set! body (cdr body)))
 790 | 		ex-nondefs)))))
 791 |   
 792 |   (define (expand-lambda-list l env)
 793 |     (if (atom? l) l
 794 | 	(cons (if (and (pair? (car l)) (pair? (cdr (car l))))
 795 | 		  (list (caar l) (expand-in (cadar l) env))
 796 | 		  (car l))
 797 | 	      (expand-lambda-list (cdr l) env))))
 798 |   
 799 |   (define (l-vars l)
 800 |     (cond ((atom? l)       (list l))
 801 | 	  ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
 802 | 	  (else            (cons (car l)  (l-vars (cdr l))))))
 803 |   
 804 |   (define (expand-lambda e env)
 805 |     (let ((formals (cadr e))
 806 | 	  (name    (lastcdr e))
 807 | 	  (body    (cddr e))
 808 | 	  (vars    (l-vars (cadr e))))
 809 |       (let ((env   (nconc (map list vars) env)))
 810 | 	`(lambda ,(expand-lambda-list formals env)
 811 | 	   ,@(expand-body body env)
 812 | 	   . ,name))))
 813 |   
 814 |   (define (expand-define e env)
 815 |     (if (or (null? (cdr e)) (atom? (cadr e)))
 816 | 	(if (null? (cddr e))
 817 | 	    e
 818 | 	    `(define ,(cadr e) ,(expand-in (caddr e) env)))
 819 | 	(let ((formals (cdadr e))
 820 | 	      (name    (caadr e))
 821 | 	      (body    (cddr e))
 822 | 	      (vars    (l-vars (cdadr e))))
 823 | 	  (let ((env   (nconc (map list vars) env)))
 824 | 	    `(define ,(cons name (expand-lambda-list formals env))
 825 | 	       ,@(expand-body body env))))))
 826 |   
 827 |   (define (expand-let-syntax e env)
 828 |     (let ((binds (cadr e)))
 829 |       (cons 'begin
 830 | 	    (expand-body (cddr e)
 831 | 			 (nconc
 832 | 			  (map (lambda (bind)
 833 | 				 (list (car bind)
 834 | 				       ((compile-thunk
 835 | 					 (expand-in (cadr bind) env)))
 836 | 				       env))
 837 | 			       binds)
 838 | 			  env)))))
 839 |   
 840 |   ; given let-syntax definition environment (menv) and environment
 841 |   ; at the point of the macro use (lenv), return the environment to
 842 |   ; expand the macro use in. TODO
 843 |   (define (local-expansion-env menv lenv) menv)
 844 |   
 845 |   (define (expand-in e env)
 846 |     (if (atom? e) e
 847 | 	(let* ((head (car e))
 848 | 	       (bnd  (assq head env))
 849 | 	       (default (lambda ()
 850 | 			  (let loop ((e e))
 851 | 			    (if (atom? e) e
 852 | 				(cons (if (atom? (car e))
 853 | 					  (car e)
 854 | 					  (expand-in (car e) env))
 855 | 				      (loop (cdr e))))))))
 856 | 	  (cond ((and bnd (pair? (cdr bnd)))  ; local macro
 857 | 		 (expand-in (apply (cadr bnd) (cdr e))
 858 | 			    (local-expansion-env (caddr bnd) env)))
 859 | 		((or bnd                      ; bound lexical or toplevel var
 860 | 		     (not (symbol? head))
 861 | 		     (bound? head))
 862 | 		 (default))
 863 | 		((macrocall? e) =>      (lambda (f)
 864 | 				          (expand-in (apply f (cdr e)) env)))
 865 | 		((eq? head 'quote)      e)
 866 | 		((eq? head 'lambda)     (expand-lambda e env))
 867 | 		((eq? head 'define)     (expand-define e env))
 868 | 		((eq? head 'let-syntax) (expand-let-syntax e env))
 869 | 		(else                   (default))))))
 870 |   (expand-in e ()))
 871 | 
 872 | (define (eval x) ((compile-thunk (expand x))))
 873 | 
 874 | (define (load-process x) (eval x))
 875 | 
 876 | (define (load filename)
 877 |   (let ((F (file filename :read)))
 878 |     (trycatch
 879 |      (let next (prev E v)
 880 |        (if (not (io.eof? F))
 881 | 	   (next (read F)
 882 |                  prev
 883 | 		 (load-process E))
 884 | 	   (begin (io.close F)
 885 | 		  ; evaluate last form in almost-tail position
 886 | 		  (load-process E))))
 887 |      (lambda (e)
 888 |        (begin
 889 | 	 (io.close F)
 890 | 	 (raise `(load-error ,filename ,e)))))))
 891 | 
 892 | (define *banner* (string.tail "
 893 | ;  _
 894 | ; |_ _ _ |_ _ |  . _ _
 895 | ; | (-||||_(_)|__|_)|_)
 896 | ;-------------------|----------------------------------------------------------
 897 | 
 898 | " 1))
 899 | 
 900 | (define (repl)
 901 |   (define (prompt)
 902 |     (princ "> ") (io.flush *output-stream*)
 903 |     (let ((v (trycatch (read)
 904 | 		       (lambda (e) (begin (io.discardbuffer *input-stream*)
 905 | 					  (raise e))))))
 906 |       (and (not (io.eof? *input-stream*))
 907 | 	   (let ((V (load-process v)))
 908 | 	     (print V)
 909 | 	     (set! that V)
 910 | 	     #t))))
 911 |   (define (reploop)
 912 |     (when (trycatch (and (prompt) (newline))
 913 | 		    (lambda (e)
 914 | 		      (top-level-exception-handler e)
 915 | 		      #t))
 916 | 	  (begin (newline)
 917 | 		 (reploop))))
 918 |   (reploop)
 919 |   (newline))
 920 | (define (top-level-exception-handler e)
 921 |   (with-output-to *stderr*
 922 | 		  (print-exception e)
 923 | 		  (print-stack-trace (stacktrace))))
 924 | 
 925 | (define (print-stack-trace st)
 926 |   (define (find-in-f f tgt path)
 927 |     (let ((path (cons (function:name f) path)))
 928 |       (if (eq? (function:code f) (function:code tgt))
 929 | 	  (throw 'ffound path)
 930 | 	  (let ((v (function:vals f)))
 931 | 	    (for 0 (1- (length v))
 932 | 		 (lambda (i) (if (closure? (aref v i))
 933 | 				 (find-in-f (aref v i) tgt path))))))))
 934 |   (define (fn-name f e)
 935 |     (let ((p (catch 'ffound
 936 | 		    (begin
 937 | 		      (for-each (lambda (topfun)
 938 | 				  (find-in-f topfun f ()))
 939 | 				e)
 940 | 		      #f))))
 941 |       (if p
 942 | 	  (symbol (string.join (map string (reverse! p)) "/"))
 943 | 	  'lambda)))
 944 |   (let ((st (reverse! (list-tail st (if *interactive* 5 4))))
 945 | 	(e (filter closure? (map (lambda (s) (and (bound? s)
 946 | 						  (top-level-value s)))
 947 | 				 (environment))))
 948 | 	(n 0))
 949 |     (for-each
 950 |      (lambda (f)
 951 |        (princ "#" n " ")
 952 |        (print (cons (fn-name (aref f 0) e)
 953 | 		    (cdr (vector->list f))))
 954 |        (newline)
 955 |        (set! n (+ n 1)))
 956 |      st)))
 957 | 
 958 | (define (print-exception e)
 959 |   (cond ((and (pair? e)
 960 | 	      (eq? (car e) 'type-error)
 961 | 	      (length= e 4))
 962 | 	 (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
 963 | 	 (print (cadddr e)))
 964 | 
 965 | 	((and (pair? e)
 966 | 	      (eq? (car e) 'bounds-error)
 967 | 	      (length= e 4))
 968 | 	 (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
 969 | 	 (print (caddr e)))
 970 | 
 971 | 	((and (pair? e)
 972 | 	      (eq? (car e) 'unbound-error)
 973 | 	      (pair? (cdr e)))
 974 | 	 (princ "eval: variable " (cadr e) " has no value"))
 975 | 
 976 | 	((and (pair? e)
 977 | 	      (eq? (car e) 'error))
 978 | 	 (princ "error: ")
 979 | 	 (apply princ (cdr e)))
 980 | 
 981 | 	((and (pair? e)
 982 | 	      (eq? (car e) 'load-error))
 983 | 	 (print-exception (caddr e))
 984 | 	 (princ "in file " (cadr e)))
 985 | 
 986 | 	((and (list? e)
 987 | 	      (length= e 2))
 988 | 	 (print (car e))
 989 | 	 (princ ": ")
 990 | 	 (let ((msg (cadr e)))
 991 | 	   ((if (or (string? msg) (symbol? msg))
 992 | 		princ print)
 993 | 	    msg)))
 994 | 
 995 | 	(else (princ "*** Unhandled exception: ")
 996 | 	      (print e)))
 997 | 
 998 |   (princ *linefeed*))
 999 | 
1000 | (define (simple-sort l)
1001 |   (if (or (null? l) (null? (cdr l))) l
1002 |       (let ((piv (car l)))
1003 | 	(receive (less grtr)
1004 | 		 (separate (lambda (x) (< x piv)) (cdr l))
1005 | 		 (nconc (simple-sort less)
1006 | 			(list piv)
1007 | 			(simple-sort grtr))))))
1008 | 
1009 | (define (make-system-image fname)
1010 |   (let ((f (file fname :write :create :truncate))
1011 | 	(excludes '(*linefeed* *directory-separator* *argv* that
1012 | 			       *print-pretty* *print-width* *print-readably*
1013 | 			       *print-level* *print-length* *os-name*)))
1014 |     (with-bindings ((*print-pretty* #t)
1015 | 		    (*print-readably* #t))
1016 |       (let ((syms
1017 | 	     (filter (lambda (s)
1018 | 		       (and (bound? s)
1019 | 			    (not (constant? s))
1020 | 			    (or (not (builtin? (top-level-value s)))
1021 | 				(not (equal? (string s) ; alias of builtin
1022 | 					     (string (top-level-value s)))))
1023 | 			    (not (memq s excludes))
1024 | 			    (not (iostream? (top-level-value s)))))
1025 | 		     (simple-sort (environment)))))
1026 | 	(write (apply nconc (map list syms (map top-level-value syms))) f)
1027 | 	(io.write f *linefeed*))
1028 |       (io.close f))))
1029 | 
1030 | ; initialize globals that need to be set at load time
1031 | (define (__init_globals)
1032 |   (if (or (eq? *os-name* 'win32)
1033 | 	  (eq? *os-name* 'win64)
1034 | 	  (eq? *os-name* 'windows))
1035 |       (begin (set! *directory-separator* "\\")
1036 | 	     (set! *linefeed* "\r\n"))
1037 |       (begin (set! *directory-separator* "/")
1038 | 	     (set! *linefeed* "\n")))
1039 |   (set! *output-stream* *stdout*)
1040 |   (set! *input-stream*  *stdin*)
1041 |   (set! *error-stream*  *stderr*))
1042 | 
1043 | (define (__script fname)
1044 |   (trycatch (load fname)
1045 | 	    (lambda (e) (begin (top-level-exception-handler e)
1046 | 			       (exit 1)))))
1047 | 
1048 | (define (__start argv)
1049 |   (__init_globals)
1050 |   (if (pair? (cdr argv))
1051 |       (begin (set! *argv* (cdr argv))
1052 | 	     (set! *interactive* #f)
1053 | 	     (__script (cadr argv)))
1054 |       (begin (set! *argv* argv)
1055 | 	     (set! *interactive* #t)
1056 | 	     (princ *banner*)
1057 | 	     (repl)))
1058 |   (exit 0)))
1059 | 


--------------------------------------------------------------------------------