stak_r7rs/
small.rs

1mod error;
2mod primitive;
3
4pub use self::error::Error;
5use self::primitive::Primitive;
6use core::ops::{Add, Div, Mul, Rem, Sub};
7use stak_device::{Device, DevicePrimitiveSet};
8use stak_file::{FilePrimitiveSet, FileSystem};
9use stak_inexact::InexactPrimitiveSet;
10use stak_native::{EqualPrimitiveSet, ListPrimitiveSet, TypeCheckPrimitiveSet};
11use stak_process_context::{ProcessContext, ProcessContextPrimitiveSet};
12use stak_time::{Clock, TimePrimitiveSet};
13use stak_vm::{Memory, Number, PrimitiveSet, Tag, Type, Value};
14use winter_maybe_async::{maybe_async, maybe_await};
15
16/// A primitive set that covers [the R7RS small](https://standards.scheme.org/corrected-r7rs/r7rs.html).
17pub struct SmallPrimitiveSet<D: Device, F: FileSystem, P: ProcessContext, C: Clock> {
18    device: DevicePrimitiveSet<D>,
19    file: FilePrimitiveSet<F>,
20    process_context: ProcessContextPrimitiveSet<P>,
21    time: TimePrimitiveSet<C>,
22    inexact: InexactPrimitiveSet,
23    equal: EqualPrimitiveSet,
24    type_check: TypeCheckPrimitiveSet,
25    list: ListPrimitiveSet,
26}
27
28impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> SmallPrimitiveSet<D, F, P, C> {
29    /// Creates a primitive set.
30    pub fn new(device: D, file_system: F, process_context: P, clock: C) -> Self {
31        Self {
32            device: DevicePrimitiveSet::new(device),
33            file: FilePrimitiveSet::new(file_system),
34            process_context: ProcessContextPrimitiveSet::new(process_context),
35            time: TimePrimitiveSet::new(clock),
36            inexact: Default::default(),
37            equal: Default::default(),
38            type_check: Default::default(),
39            list: Default::default(),
40        }
41    }
42
43    /// Returns a reference to a device.
44    pub fn device(&self) -> &D {
45        self.device.device()
46    }
47
48    /// Returns a mutable reference to a device.
49    pub fn device_mut(&mut self) -> &mut D {
50        self.device.device_mut()
51    }
52
53    fn operate_comparison(
54        memory: &mut Memory,
55        operate: fn(Number, Number) -> bool,
56    ) -> Result<(), Error> {
57        let [x, y] = memory.pop_numbers()?;
58
59        memory.push(memory.boolean(operate(x, y))?.into())?;
60        Ok(())
61    }
62
63    fn rib(memory: &mut Memory, car: Value, cdr: Value, tag: Tag) -> Result<(), Error> {
64        let rib = memory.allocate(car, cdr.set_tag(tag))?;
65        memory.push(rib.into())?;
66        Ok(())
67    }
68
69    // We mark this `inline(always)` to make sure inline the `set_field` functions
70    // everywhere.
71    #[inline(always)]
72    fn set_field<'a>(
73        memory: &mut Memory<'a>,
74        set_field: fn(&mut Memory<'a>, Value, Value) -> Result<(), stak_vm::Error>,
75    ) -> Result<(), Error> {
76        let [x, y] = memory.pop_many()?;
77
78        set_field(memory, x, y)?;
79        memory.push(y)?;
80        Ok(())
81    }
82
83    fn tag<'a>(
84        memory: &mut Memory<'a>,
85        field: impl Fn(&Memory<'a>, Value) -> Result<Value, stak_vm::Error>,
86    ) -> Result<(), Error> {
87        memory.operate_top(|memory, value| {
88            Ok(if let Some(cons) = field(memory, value)?.to_cons() {
89                Number::from_i64(cons.tag() as _)
90            } else {
91                Default::default()
92            }
93            .into())
94        })?;
95
96        Ok(())
97    }
98}
99
100impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSet
101    for SmallPrimitiveSet<D, F, P, C>
102{
103    type Error = Error;
104
105    #[maybe_async]
106    fn operate(&mut self, memory: &mut Memory<'_>, primitive: usize) -> Result<(), Self::Error> {
107        match primitive {
108            Primitive::RIB => {
109                let [car, cdr, tag] = memory.pop_many()?;
110
111                Self::rib(memory, car, cdr, tag.assume_number().to_i64() as _)?;
112            }
113            Primitive::CLOSE => {
114                let closure = memory.pop()?;
115
116                Self::rib(
117                    memory,
118                    memory.car_value(closure)?,
119                    memory.stack().into(),
120                    Type::Procedure as _,
121                )?;
122            }
123            Primitive::IS_RIB => {
124                memory.operate_top(|memory, value| Ok(memory.boolean(value.is_cons())?.into()))?
125            }
126            Primitive::CAR => memory.operate_top(Memory::car_value)?,
127            Primitive::CDR => memory.operate_top(Memory::cdr_value)?,
128            Primitive::TAG => Self::tag(memory, Memory::cdr_value)?,
129            Primitive::SET_CAR => Self::set_field(memory, Memory::set_car_value)?,
130            Primitive::SET_CDR => Self::set_field(memory, Memory::set_cdr_value)?,
131            Primitive::EQUAL => {
132                let [x, y] = memory.pop_many()?;
133                memory.push(memory.boolean(x == y)?.into())?;
134            }
135            Primitive::LESS_THAN => Self::operate_comparison(memory, |x, y| x < y)?,
136            Primitive::ADD => memory.operate_binary(Add::add)?,
137            Primitive::SUBTRACT => memory.operate_binary(Sub::sub)?,
138            Primitive::MULTIPLY => memory.operate_binary(Mul::mul)?,
139            Primitive::DIVIDE => memory.operate_binary(Div::div)?,
140            Primitive::REMAINDER => memory.operate_binary(Rem::rem)?,
141            Primitive::EXPONENTIATION
142            | Primitive::LOGARITHM
143            | Primitive::INFINITE
144            | Primitive::NAN
145            | Primitive::SQRT
146            | Primitive::COS
147            | Primitive::SIN
148            | Primitive::TAN
149            | Primitive::ACOS
150            | Primitive::ASIN
151            | Primitive::ATAN => maybe_await!(
152                self.inexact
153                    .operate(memory, primitive - Primitive::EXPONENTIATION)
154            )?,
155            Primitive::HALT => return Err(Error::Halt),
156            Primitive::NULL | Primitive::PAIR => {
157                maybe_await!(self.type_check.operate(memory, primitive - Primitive::NULL))?
158            }
159            Primitive::ASSQ | Primitive::CONS | Primitive::MEMQ => {
160                maybe_await!(self.list.operate(memory, primitive - Primitive::ASSQ))?
161            }
162            Primitive::EQV | Primitive::EQUAL_INNER => {
163                maybe_await!(self.equal.operate(memory, primitive - Primitive::EQV))?
164            }
165            Primitive::READ | Primitive::WRITE | Primitive::WRITE_ERROR => {
166                maybe_await!(self.device.operate(memory, primitive - Primitive::READ))?
167            }
168            Primitive::OPEN_FILE
169            | Primitive::CLOSE_FILE
170            | Primitive::READ_FILE
171            | Primitive::WRITE_FILE
172            | Primitive::DELETE_FILE
173            | Primitive::EXISTS_FILE
174            | Primitive::FLUSH_FILE => {
175                maybe_await!(self.file.operate(memory, primitive - Primitive::OPEN_FILE))?
176            }
177            Primitive::COMMAND_LINE | Primitive::ENVIRONMENT_VARIABLES => maybe_await!(
178                self.process_context
179                    .operate(memory, primitive - Primitive::COMMAND_LINE)
180            )?,
181            Primitive::CURRENT_JIFFY | Primitive::JIFFIES_PER_SECOND => maybe_await!(
182                self.time
183                    .operate(memory, primitive - Primitive::CURRENT_JIFFY)
184            )?,
185            _ => return Err(stak_vm::Error::IllegalPrimitive.into()),
186        }
187
188        Ok(())
189    }
190}
stak_r7rs/small.rs

stak_r7rs/
small.rs
